Initial revision

compiler/aasm.pas

@@ -0,0 +1,767 @@
+{
+    $Id$
+    Copyright (c) 1996-98 by Florian Klaempfl
+
+    This unit implements an abstract asmoutput class for all processor types
+
+    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 aasm;
+
+  interface
+
+    uses
+       cobjects,files,globals;
+
+{$I version.inc}
+    type
+{$ifdef klaempfl}
+{$ifdef ver0_9_2}
+       extended = double;
+{$endif ver0_9_2}
+{$endif klaempfl}
+       tait = (
+          ait_string,
+          ait_label,
+          ait_direct,
+          ait_labeled_instruction,
+          ait_comment,
+          ait_instruction,
+          ait_datablock,
+          ait_symbol,
+          ait_const_32bit,
+          ait_const_symbol,
+          ait_const_16bit,
+          ait_const_8bit,
+          ait_real_64bit,
+          ait_real_32bit,
+          ait_real_extended,
+          ait_comp,
+          ait_external,
+          ait_align,
+
+          { the following is only used by the win32 version of the compiler }
+          { and only the GNU AS Win32 is able to write it                   }
+          ait_section,
+          ait_const_rva,
+          { the following must is system depended }
+{$ifdef GDB}
+          ait_stabn,
+          ait_stabs,
+          ait_stab_function_name,
+{$endif GDB}
+{$ifdef MAKELIB}
+          { used to split unit into tiny assembler files }
+          ait_cut,
+{$endif MAKELIB}
+          { never used, makes insertation of new ait_ easier to type }
+          ait_dummy);
+
+     type
+       { the short name makes typing easier }
+       pai = ^tai;
+
+       tai = object(tlinkedlist_item)
+          typ : tait;
+          line : longint;
+          infile : pinputfile;
+          constructor init;
+       end;
+
+       pai_string = ^tai_string;
+
+       tai_string = object(tai)
+          str : pchar;
+          { extra len so the string can contain an \0 }
+          len : longint;
+          constructor init(const _str : string);
+          constructor init_pchar(_str : pchar);
+          destructor done;virtual;
+       end;
+
+       pai_symbol = ^tai_symbol;
+
+       { generates a common label }
+       tai_symbol = object(tai)
+          name : pchar;
+          is_global : boolean;
+          constructor init(const _name : string);
+          constructor init_global(const _name : string);
+          destructor done;virtual;
+       end;
+
+       { external types defined for TASM }
+       { EXT_ANY for search purposes     }
+       texternal_typ = (EXT_ANY,EXT_NEAR, EXT_FAR, EXT_PROC, EXT_BYTE,
+                       EXT_WORD, EXT_DWORD, EXT_CODEPTR, EXT_DATAPTR,
+                       EXT_FWORD, EXT_PWORD, EXT_QWORD, EXT_TBYTE, EXT_ABS);
+
+       pai_external = ^tai_external;
+
+       { generates an symbol which is marked as external }
+       tai_external = object(tai)
+          name : pchar;
+          exttyp : texternal_typ;
+          constructor init(const _name : string;exttype : texternal_typ);
+          destructor done; virtual;
+       end;
+
+       { simple temporary label }
+       pai_label = ^tai_label;
+
+       { type for a temporary label }
+       { test if used for dispose of unnecessary labels }
+       tlabel = record
+                nb : longint;
+                is_used : boolean;
+                is_set : boolean;
+                refcount : word;
+                end;
+
+       plabel = ^tlabel;
+
+       tai_label = object(tai)
+          l : plabel;
+          constructor init(_l : plabel);
+          destructor done; virtual;
+       end;
+
+       pai_direct = ^tai_direct;
+       tai_direct = object(tai)
+          str : pchar;
+          constructor init(_str : pchar);
+          destructor done; virtual;
+       end;
+
+
+       { alignment for operator }
+       pai_align = ^tai_align;
+       tai_align = object(tai)
+          aligntype: byte;   { 1 = no align, 2 = word align, 4 = dword align }
+          op: byte;          { value to fill with - optional                 }
+          constructor init(b:byte);
+          constructor init_op(b: byte; use_op: byte);
+          destructor done;virtual;
+       end;
+
+       pai_section = ^tai_section;
+
+       tai_section = object(tai)
+          name : pstring;
+          constructor init(const s : string);
+          destructor done;virtual;
+       end;
+
+       pai_datablock = ^tai_datablock;
+
+       { generates an uninitilizised data block }
+       tai_datablock = object(tai)
+          size : longint;
+          name : pchar;
+          is_global : boolean;
+          constructor init(const _name : string;_size : longint);
+          constructor init_global(const _name : string;_size : longint);
+          destructor done; virtual;
+       end;
+
+       pai_const = ^tai_const;
+
+       { generates a long integer (32 bit) }
+       tai_const = object(tai)
+          value : longint;
+          constructor init_32bit(_value : longint);
+          constructor init_16bit(_value : word);
+          constructor init_8bit(_value : byte);
+          constructor init_symbol(p : pchar);
+          constructor init_rva(p : pchar);
+          destructor done;virtual;
+       end;
+
+       pai_double = ^tai_double;
+
+       { generates a double (64 bit real) }
+       tai_double = object(tai)
+          value : double;
+          constructor init(_value : double);
+       end;
+
+       pai_single = ^tai_single;
+
+       { generates a single (32 bit real) }
+       tai_single = object(tai)
+          value : single;
+          constructor init(_value : single);
+       end;
+
+       pai_extended = ^tai_extended;
+
+       { generates an extended (80 bit real) }
+       { for version above v0_9_8            }
+       { creates a double otherwise          }
+       tai_extended = object(tai)
+          value : bestreal;
+          constructor init(_value : bestreal);
+       end;
+{$ifdef MAKELIB}
+       pai_cut = ^tai_cut;
+
+       tai_cut = object(tai)
+          constructor init;
+       end;
+{$endif MAKELIB}
+
+{ for each processor define the best precision }
+{ bestreal is defined in globals }
+{$ifdef i386}
+{$ifdef ver_above0_9_8}
+const
+       ait_bestreal = ait_real_extended;
+type
+       pai_bestreal = pai_extended;
+       tai_bestreal = tai_extended;
+{$else ver_above0_9_8}
+const
+       ait_bestreal = ait_real_64bit;
+type
+       pai_bestreal = pai_double;
+       tai_bestreal = tai_double;
+{$endif ver_above0_9_8}
+{$endif i386}
+{$ifdef m68k}
+const
+       ait_bestreal = ait_real_32bit;
+type
+       pai_bestreal = pai_single;
+       tai_bestreal = tai_single;
+{$endif m68k}
+
+       pai_comp = ^tai_comp;
+
+       { generates an comp (integer over 64 bits) }
+       tai_comp = object(tai)
+          value : bestreal;
+          constructor init(_value : bestreal);
+       end;
+
+       paasmoutput = ^taasmoutput;
+       taasmoutput = tlinkedlist;
+
+    var
+      datasegment,codesegment,bsssegment,
+      internals,externals,debuglist,consts,importssection,
+      exportssection,resourcesection : paasmoutput;
+
+   { external symbols without repetition }
+    function search_assembler_symbol(pl : paasmoutput;const _name : string;exttype : texternal_typ) : pai_external;
+    procedure concat_external(const _name : string;exttype : texternal_typ);
+    procedure concat_internal(const _name : string;exttype : texternal_typ);
+
+  implementation
+
+  uses strings,verbose;
+
+{****************************************************************************
+                             TAI
+ ****************************************************************************}
+
+    constructor tai.init;
+
+      begin
+{$ifdef GDB}
+         infile:=pointer(current_module^.current_inputfile);
+         if assigned(infile) then
+           line:=current_module^.current_inputfile^.line_no;
+{$endif GDB}
+      end;
+{****************************************************************************
+                             TAI_SECTION
+ ****************************************************************************}
+
+    constructor tai_section.init(const s : string);
+
+      begin
+         inherited init;
+         typ:=ait_section;
+         name:=stringdup(s);
+      end;
+
+    destructor tai_section.done;
+
+      begin
+         stringdispose(name);
+         inherited done;
+      end;
+
+{****************************************************************************
+                             TAI_DATABLOCK
+ ****************************************************************************}
+
+    constructor tai_datablock.init(const _name : string;_size : longint);
+
+      begin
+         inherited init;
+         typ:=ait_datablock;
+         name:=strpnew(_name);
+         concat_internal(_name,EXT_ANY);
+         size:=_size;
+         is_global:=false;
+      end;
+
+    constructor tai_datablock.init_global(const _name : string;_size : longint);
+
+      begin
+         inherited init;
+         typ:=ait_datablock;
+         name:=strpnew(_name);
+         concat_internal(_name,EXT_ANY);
+         size:=_size;
+         is_global:=true;
+      end;
+
+    destructor tai_datablock.done;
+
+      begin
+         strdispose(name);
+         inherited done;
+      end;
+
+{****************************************************************************
+                               TAI_SYMBOL
+ ****************************************************************************}
+
+    constructor tai_symbol.init(const _name : string);
+
+      begin
+         inherited init;
+         typ:=ait_symbol;
+         name:=strpnew(_name);
+         concat_internal(_name,EXT_ANY);
+         is_global:=false;
+      end;
+
+    constructor tai_symbol.init_global(const _name : string);
+
+      begin
+         inherited init;
+         typ:=ait_symbol;
+         name:=strpnew(_name);
+         concat_internal(_name,EXT_ANY);
+         is_global:=true;
+      end;
+
+    destructor tai_symbol.done;
+
+      begin
+         strdispose(name);
+         inherited done;
+      end;
+
+{****************************************************************************
+                               TAI_EXTERNAL
+ ****************************************************************************}
+
+    constructor tai_external.init(const _name : string;exttype : texternal_typ);
+
+      begin
+         inherited init;
+         typ:=ait_external;
+         exttyp:=exttype;
+         name:=strpnew(_name);
+      end;
+
+    destructor tai_external.done;
+
+      begin
+         strdispose(name);
+         inherited done;
+      end;
+
+    function search_assembler_symbol(pl : paasmoutput;const _name : string;exttype : texternal_typ) : pai_external;
+
+      var
+         p : pai;
+
+      begin
+         search_assembler_symbol:=nil;
+         if pl=nil then
+           internalerror(2001)
+         else
+           begin
+              p:=pai(pl^.first);
+              while (p<>nil) and
+                    (p<>pai(pl^.last)) do
+                { if we get the same name with a different typ }
+                { there is probably an error                   }
+                if (p^.typ=ait_external) and
+                   ((exttype=EXT_ANY) or (pai_external(p)^.exttyp=exttype)) and
+                   (strpas(pai_external(p)^.name)=_name) then
+                  begin
+                     search_assembler_symbol:=pai_external(p);
+                     exit;
+                  end
+                else
+                  p:=pai(p^.next);
+              if (p<>nil) and
+                 (p^.typ=ait_external) and
+                 (pai_external(p)^.exttyp=exttype) and
+                 (strpas(pai_external(p)^.name)=_name) then
+                begin
+                   search_assembler_symbol:=pai_external(p);
+                   exit;
+                end;
+           end;
+      end;
+
+    { insert each need external only once }
+    procedure concat_external(const _name : string;exttype : texternal_typ);
+
+      var
+         p : pai_external;
+
+      begin
+         p:=search_assembler_symbol(externals,_name,exttype);
+         if p=nil then
+           externals^.concat(new(pai_external,init(_name,exttype)));
+      end;
+
+    { insert each need external only once }
+    procedure concat_internal(const _name : string;exttype : texternal_typ);
+
+      var
+         p : pai_external;
+
+      begin
+         p:=search_assembler_symbol(internals,_name,exttype);
+         if p=nil then
+           internals^.concat(new(pai_external,init(_name,exttype)));
+      end;
+
+{****************************************************************************
+                               TAI_CONST
+ ****************************************************************************}
+
+    constructor tai_const.init_32bit(_value : longint);
+
+      begin
+         inherited init;
+         typ:=ait_const_32bit;
+         value:=_value;
+      end;
+
+    constructor tai_const.init_16bit(_value : word);
+
+      begin
+         inherited init;
+         typ:=ait_const_16bit;
+         value:=_value;
+      end;
+
+    constructor tai_const.init_8bit(_value : byte);
+
+      begin
+         inherited init;
+         typ:=ait_const_8bit;
+         value:=_value;
+      end;
+
+    constructor tai_const.init_symbol(p : pchar);
+
+      begin
+         inherited init;
+         typ:=ait_const_symbol;
+         value:=longint(p);
+      end;
+
+    constructor tai_const.init_rva(p : pchar);
+
+      begin
+         inherited init;
+         typ:=ait_const_rva;
+         value:=longint(p);
+      end;
+
+    destructor tai_const.done;
+
+      begin
+         if typ=ait_const_symbol then
+           strdispose(pchar(value));
+         inherited done;
+      end;
+
+{****************************************************************************
+                               TAI_DOUBLE
+ ****************************************************************************}
+
+    constructor tai_double.init(_value : double);
+
+      begin
+         inherited init;
+         typ:=ait_real_64bit;
+         value:=_value;
+      end;
+
+{****************************************************************************
+                               TAI_SINGLE
+ ****************************************************************************}
+
+    constructor tai_single.init(_value : single);
+
+      begin
+         inherited init;
+         typ:=ait_real_32bit;
+         value:=_value;
+      end;
+
+{****************************************************************************
+                               TAI_EXTENDED
+ ****************************************************************************}
+
+    constructor tai_extended.init(_value : bestreal);
+
+      begin
+         inherited init;
+         typ:=ait_real_extended;
+         value:=_value;
+      end;
+
+{****************************************************************************
+                               TAI_COMP
+ ****************************************************************************}
+
+    constructor tai_comp.init(_value : bestreal);
+
+      begin
+         inherited init;
+         typ:=ait_comp;
+         value:=_value;
+      end;
+
+{****************************************************************************
+                               TAI_STRING
+ ****************************************************************************}
+
+     constructor tai_string.init(const _str : string);
+
+       begin
+          inherited init;
+          typ:=ait_string;
+          getmem(str,length(_str)+1);
+          strpcopy(str,_str);
+          len:=length(_str);
+       end;
+
+     constructor tai_string.init_pchar(_str : pchar);
+
+       begin
+          inherited init;
+          typ:=ait_string;
+          str:=_str;
+          len:=strlen(_str);
+       end;
+
+    destructor tai_string.done;
+
+      begin
+         { you can have #0 inside the strings so }
+         if str<>nil then
+           freemem(str,len+1);
+         inherited done;
+      end;
+
+{****************************************************************************
+                               TAI_LABEL
+ ****************************************************************************}
+
+     constructor tai_label.init(_l : plabel);
+
+       begin
+          inherited init;
+          typ:=ait_label;
+          l:=_l;
+          l^.is_set:=true;
+          { suggestion of JM:
+            inc(l^.refcount); }
+       end;
+
+    destructor tai_label.done;
+
+      begin
+         { suggestion of JM:
+         dec(l^.refcount);  }
+         if (l^.is_used) then
+           l^.is_set:=false
+         else dispose(l);
+         inherited done;
+      end;
+
+{****************************************************************************
+                              TAI_DIRECT
+ ****************************************************************************}
+
+     constructor tai_direct.init(_str : pchar);
+
+       begin
+          inherited init;
+          typ:=ait_direct;
+          str:=_str;
+       end;
+
+    destructor tai_direct.done;
+
+      begin
+         strdispose(str);
+         inherited done;
+      end;
+
+{****************************************************************************
+                              TAI_ALIGN
+ ****************************************************************************}
+
+     constructor tai_align.init(b: byte);
+
+       begin
+          inherited init;
+          typ:=ait_align;
+          if b in [1,2,4,8,16] then
+           aligntype := b
+          else
+           aligntype := 1;
+          op:=0;
+       end;
+
+
+     constructor tai_align.init_op(b: byte; use_op: byte);
+
+       begin
+          inherited init;
+          typ:=ait_align;
+          if b in [1,2,4,8,16] then
+           aligntype := b
+          else
+           aligntype := 1;
+           op:=use_op;
+       end;
+
+    destructor tai_align.done;
+
+      begin
+         inherited done;
+      end;
+
+{$ifdef MAKELIB}
+{****************************************************************************
+                              TAI_CUT
+ ****************************************************************************}
+
+     constructor tai_cut.init;
+
+       begin
+          inherited init;
+          typ:=ait_cut;
+       end;
+{$endif MAKELIB}
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:16  root
+  Initial revision
+
+  Revision 1.18  1998/03/10 16:27:36  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.17  1998/03/10 01:17:13  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.16  1998/03/02 01:47:56  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/28 14:43:46  florian
+    * final implemenation of win32 imports
+    * extended tai_align to allow 8 and 16 byte aligns
+
+  Revision 1.14  1998/02/28 00:20:20  florian
+    * more changes to get import libs for Win32 working
+
+  Revision 1.13  1998/02/27 22:27:50  florian
+    + win_targ unit
+    + support of sections
+    + new asmlists: sections, exports and resource
+
+  Revision 1.12  1998/02/24 00:19:08  peter
+    * makefile works again (btw. linux does like any char after a \ )
+    * removed circular unit with assemble and files
+    * fixed a sigsegv in pexpr
+    * pmodule init unit/program is the almost the same, merged them
+
+  Revision 1.11  1998/02/13 10:34:29  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.10  1998/02/06 23:08:31  florian
+    + endian to targetinfo and sourceinfo added
+    + endian independed writing of ppu file (reading missed), a PPU file
+      is written with the target endian
+
+  Revision 1.9  1998/01/11 04:14:30  carl
+  + correct floating point support for m68k
+
+  Revision 1.6  1997/12/09 13:18:34  carl
+  + added pai_align abstract object (required for m68k)
+  + renamed ait_real_s80bit --> ait_real_extended
+
+  Revision 1.5  1997/12/01 18:14:32  pierre
+      * fixes a bug in nasm output due to my previous changes
+
+  Revision 1.3  1997/11/28 18:14:17  pierre
+   working version with several bug fixes
+
+  Revision 1.2  1997/11/28 14:26:18  florian
+  Fixed some bugs
+
+  Revision 1.1.1.1  1997/11/27 08:32:50  michael
+  FPC Compiler CVS start
+
+  Pre-CVS log:
+
+  FK     Florian Klaempfl
+  PM     Pierre Muller
+  +      feature added
+  -      removed
+  *      bug fixed or changed
+
+  History:
+      30th september 1996:
+         + unit started
+      13th november 1997:
+         + added pai_single and pai_extended (PM)
+      14th november 1997:
+         + added bestreal type and pai_bestreal
+           to store all real consts with best precision (PM)
+           has a drawback for GDB that does not know extended !! (PM)
+
+}

compiler/ag386int.pas

@@ -0,0 +1,793 @@
+{
+    $Id$
+    Copyright (c) 1996,97 by Florian Klaempfl
+
+    This unit implements an asmoutput class for Intel syntax with Intel i386+
+
+    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 ag386int;
+
+    interface
+
+    uses aasm,assemble;
+
+    type
+      pi386intasmlist=^ti386intasmlist;
+      ti386intasmlist = object(tasmlist)
+        procedure WriteTree(p:paasmoutput);virtual;
+        procedure WriteAsmList;virtual;
+      end;
+
+  implementation
+
+    uses
+      dos,globals,systems,cobjects,i386,
+      strings,files,verbose
+{$ifdef GDB}
+      ,gdb
+{$endif GDB}
+      ;
+
+    const
+      line_length = 70;
+
+      extstr : array[EXT_NEAR..EXT_ABS] of String[8] =
+             ('NEAR','FAR','PROC','BYTE','WORD','DWORD',
+              'CODEPTR','DATAPTR','FWORD','PWORD','QWORD','TBYTE','ABS');
+
+    function getreferencestring(const ref : treference) : string;
+    var
+      s     : string;
+      first : boolean;
+    begin
+      if ref.isintvalue then
+       s:= tostr(ref.offset)
+      else
+{$ifdef ver0_6}
+       begin
+      first:=true;
+      { have we a segment prefix ? }
+      if ref.segment<>R_DEFAULT_SEG then
+      begin
+        if current_module^.output_format in [of_nasm,of_obj] then
+          s:='['+_reg2str[ref.segment]+':'
+        else
+          s:=_reg2str[ref.segment]+':[';
+      end
+      else s:='[';
+
+      if assigned(ref.symbol) then
+        begin
+           s:=s+ref.symbol^;
+           first:=false;
+        end;
+      if (ref.base<>R_NO) then
+        begin
+           if not(first) then
+             s:=s+'+'
+           else
+             first:=false;
+           s:=s+_reg2str[ref.base];
+        end;
+      if (ref.index<>R_NO) then
+        begin
+           if not(first) then
+             s:=s+'+'
+           else
+             first:=false;
+           s:=s+_reg2str[ref.index];
+           if ref.scalefactor<>0 then
+             s:=s+'*'+tostr(ref.scalefactor);
+        end;
+      if ref.offset<0 then
+        s:=s+tostr(ref.offset)
+      else if (ref.offset>0) then
+        s:=s+'+'+tostr(ref.offset);
+      s:=s+']';
+        end;
+{$else}
+      with ref do
+        begin
+          first:=true;
+          if ref.segment<>R_DEFAULT_SEG then
+           begin
+             if current_module^.output_format in [of_nasm,of_obj] then
+              s:='['+int_reg2str[segment]+':'
+             else
+              s:=int_reg2str[segment]+':[';
+           end
+          else
+           s:='[';
+
+         if assigned(symbol) then
+          begin
+            s:=s+symbol^;
+            first:=false;
+          end;
+         if (base<>R_NO) then
+          begin
+            if not(first) then
+             s:=s+'+'
+            else
+             first:=false;
+             s:=s+int_reg2str[base];
+          end;
+         if (index<>R_NO) then
+           begin
+             if not(first) then
+               s:=s+'+'
+             else
+               first:=false;
+             s:=s+int_reg2str[index];
+             if scalefactor<>0 then
+               s:=s+'*'+tostr(scalefactor);
+           end;
+         if offset<0 then
+           s:=s+tostr(offset)
+         else if (offset>0) then
+           s:=s+'+'+tostr(offset);
+         s:=s+']';
+        end;
+{$endif}
+       getreferencestring:=s;
+     end;
+
+    function getopstr(t : byte;o : pointer;s : topsize; _operator: tasmop;dest : boolean) : string;
+
+      var
+    hs : string;
+
+      begin
+    case t of
+       top_reg : { a floating point register can be only a register operand }
+            if current_module^.output_format in [of_nasm,of_obj] then
+               getopstr:=int_nasmreg2str[tregister(o)]
+            else
+               getopstr:=int_reg2str[tregister(o)];
+       top_const,
+       top_ref : begin
+                  if t=top_const then
+                    hs := tostr(longint(o))
+                  else
+                    hs:=getreferencestring(preference(o)^);
+                  if current_module^.output_format in [of_nasm,of_obj] then
+                    if (_operator = A_LEA) or (_operator = A_LGS)
+                    or (_operator = A_LSS) or (_operator = A_LFS)
+                    or (_operator = A_LES) or (_operator = A_LDS)
+                    or (_operator = A_SHR) or (_operator = A_SHL)
+                    or (_operator = A_SAR) or (_operator = A_SAL)
+                    or (_operator = A_OUT) or (_operator = A_IN) then
+                    begin
+                    end
+                    else
+                      case s of
+                         S_B : hs:='byte '+hs;
+                         S_W : hs:='word '+hs;
+                         S_L : hs:='dword '+hs;
+                         S_S : hs:='dword '+hs;
+                         S_Q : hs:='qword '+hs;
+                         S_X : if current_module^.output_format in [of_nasm,of_obj] then
+                                 hs:='tword '+hs
+                               else
+                                 hs:='tbyte '+hs;
+                         S_BW : if dest then
+                             hs:='word '+hs
+                           else
+                             hs:='byte '+hs;
+                         S_BL : if dest then
+                             hs:='dword '+hs
+                           else
+                             hs:='byte '+hs;
+                         S_WL : if dest then
+                             hs:='dword '+hs
+                           else
+                             hs:='word '+hs;
+                      end
+          else
+          Begin
+            { can possibly give a range check error under tp }
+            { if using in...                                 }
+            if ((_operator <> A_LGS) and (_operator <> A_LSS) and
+               (_operator <> A_LFS) and (_operator <> A_LDS) and
+               (_operator <> A_LES)) then
+            Begin
+            case s of
+               S_B : hs:='byte ptr '+hs;
+               S_W : hs:='word ptr '+hs;
+               S_L : hs:='dword ptr '+hs;
+               S_BW : if dest then
+                   hs:='word ptr '+hs
+                 else
+                   hs:='byte ptr '+hs;
+               S_BL : if dest then
+                   hs:='dword ptr '+hs
+                 else
+                   hs:='byte ptr '+hs;
+               S_WL : if dest then
+                   hs:='dword ptr '+hs
+                 else
+                   hs:='word ptr '+hs;
+            end;
+            end;
+          end;
+              getopstr:=hs;
+            end;
+       top_symbol : begin
+             hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
+             move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
+             if current_module^.output_format=of_masm then
+               hs:='offset '+hs
+             else
+               hs:='dword '+hs;
+
+             if pcsymbol(o)^.offset>0 then
+               hs:=hs+'+'+tostr(pcsymbol(o)^.offset)
+             else if pcsymbol(o)^.offset<0 then
+               hs:=hs+tostr(pcsymbol(o)^.offset);
+             getopstr:=hs;
+          end;
+       else internalerror(10001);
+    end;
+      end;
+
+    function getopstr_jmp(t : byte;o : pointer) : string;
+
+      var
+    hs : string;
+
+      begin
+    case t of
+       top_reg : getopstr_jmp:=int_reg2str[tregister(o)];
+       top_ref : getopstr_jmp:=getreferencestring(preference(o)^);
+       top_const : getopstr_jmp:=tostr(longint(o));
+       top_symbol : begin
+             hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
+             move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
+             if pcsymbol(o)^.offset>0 then
+               hs:=hs+'+'+tostr(pcsymbol(o)^.offset)
+             else if pcsymbol(o)^.offset<0 then
+               hs:=hs+tostr(pcsymbol(o)^.offset);
+             getopstr_jmp:=hs;
+          end;
+       else internalerror(10001);
+    end;
+      end;
+
+{****************************************************************************
+                               TI386INTASMLIST
+ ****************************************************************************}
+
+    const
+      ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]=
+        (#9'DD'#9,'',#9'DW'#9,#9'DB'#9);
+
+    Function PadTabs(p:pchar;addch:char):string;
+    var
+      s : string;
+      i : longint;
+    begin
+      i:=strlen(p);
+      if addch<>#0 then
+       begin
+         inc(i);
+         s:=StrPas(p)+addch;
+       end
+      else
+       s:=StrPas(p);
+      if i<8 then
+       PadTabs:=s+#9#9
+      else
+       PadTabs:=s+#9;
+    end;
+
+    procedure ti386intasmlist.WriteTree(p:paasmoutput);
+    type
+      twowords=record
+        word1,word2:word;
+      end;
+    var
+      s,
+      prefix,
+      suffix   : string;
+      hp       : pai;
+      counter,
+      lines,
+      i,j,l    : longint;
+      consttyp : tait;
+      found,
+      quoted   : boolean;
+    begin
+      hp:=pai(p^.first);
+      while assigned(hp) do
+       begin
+         case hp^.typ of
+       ait_comment : ;
+         ait_align : begin
+                     { align not supported at all with nasm v095  }
+                     { align with specific value not supported by }
+                     { turbo assembler.                           }
+                     { CAUSES PROBLEMS WITH THE SEGMENT DEFINITION   }
+                     { SEGMENT DEFINITION SHOULD MATCH TYPE OF ALIGN }
+                     { HERE UNDER TASM!                              }
+{                      if current_module^.output_format<>of_nasm then
+                        AsmWriteLn(#9'ALIGN '+tostr(pai_align(hp)^.aligntype));}
+                     end;
+      ait_external : begin
+                       if current_module^.output_format in [of_nasm,of_obj] then
+                        AsmWriteLn('EXTERN '+StrPas(pai_external(hp)^.name))
+                       else
+                        AsmWriteLn(#9#9'EXTRN'#9+StrPas(pai_external(hp)^.name)+
+                                   ' :'+extstr[pai_external(hp)^.exttyp]);
+                     end;
+     ait_datablock : begin
+                       if current_module^.output_format in [of_nasm,of_obj] then
+                        begin
+                          if pai_symbol(hp)^.is_global then
+                           AsmWriteLn('GLOBAL '+StrPas(pai_datablock(hp)^.name));
+                          AsmWriteLn(PadTabs(pai_datablock(hp)^.name,':')+'RESB'#9+tostr(pai_datablock(hp)^.size));
+                        end
+                       else
+                        begin
+                          if pai_symbol(hp)^.is_global then
+                           AsmWriteLn(#9#9'PUBLIC'#9+StrPas(pai_datablock(hp)^.name));
+                          AsmWriteLn(PadTabs(pai_datablock(hp)^.name,#0)+'DB'#9+tostr(pai_datablock(hp)^.size)+' DUP(?)');
+                        end;
+                     end;
+   ait_const_32bit,
+    ait_const_8bit,
+   ait_const_16bit : begin
+                       AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value));
+                       consttyp:=hp^.typ;
+                       l:=0;
+                       repeat
+                         found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp);
+                         if found then
+                          begin
+                            hp:=Pai(hp^.next);
+                            s:=','+tostr(pai_const(hp)^.value);
+                            AsmWrite(s);
+                            inc(l,length(s));
+                          end;
+                       until (not found) or (l>line_length);
+                       AsmLn;
+                     end;
+  ait_const_symbol : begin
+                       if current_module^.output_format<>of_nasm then
+                        AsmWrite(#9#9+'DD '#9'offset ')
+                       else
+                        AsmWrite(#9#9+'DD '#9);
+                       AsmWriteLn(StrPas(pchar(pai_const(hp)^.value)));
+                     end;
+    ait_real_32bit : AsmWriteLn(#9#9'DD'#9+double2str(pai_single(hp)^.value));
+    ait_real_64bit : AsmWriteLn(#9#9'DQ'#9+double2str(pai_double(hp)^.value));
+ ait_real_extended : begin
+                     { nasm v095 does not like DT with real constants }
+                     { therefore write as double.                     }
+                     { other possible solution: decode directly to hex}
+                     { value.                                         }
+                       if current_module^.output_format<>of_nasm then
+                        AsmWriteLn(#9#9'DT'#9+double2str(pai_extended(hp)^.value))
+                       else
+                        begin
+{$ifdef EXTDEBUG}
+                          AsmLn;
+                          AsmWriteLn('; NASM bug work around for extended real');
+{$endif}
+                          AsmWriteLn(#9#9'DD'#9+double2str(pai_extended(hp)^.value))
+                        end;
+                     end;
+          ait_comp : AsmWriteLn(#9#9'DQ'#9+comp2str(pai_extended(hp)^.value));
+        ait_string : begin
+                  counter := 0;
+                  lines := pai_string(hp)^.len div line_length;
+                  { separate lines in different parts }
+                  if pai_string(hp)^.len > 0 then
+                      Begin
+                        for j := 0 to lines-1 do
+                          begin
+                             AsmWrite(#9#9'DB'#9);
+                             quoted:=false;
+                             for i:=counter to counter+line_length do
+                                begin
+                                  { it is an ascii character. }
+                                  if (ord(pai_string(hp)^.str[i])>31) and
+                                     (ord(pai_string(hp)^.str[i])<128) and
+                                     (pai_string(hp)^.str[i]<>'"') then
+                                      begin
+                                        if not(quoted) then
+                                            begin
+                                              if i>counter then
+                                                AsmWrite(',');
+                                              AsmWrite('"');
+                                            end;
+                                        AsmWrite(pai_string(hp)^.str[i]);
+                                        quoted:=true;
+                                      end { if > 31 and < 128 and ord('"') }
+                                  else
+                                      begin
+                                          if quoted then
+                                              AsmWrite('"');
+                                          if i>counter then
+                                              AsmWrite(',');
+                                          quoted:=false;
+                                          AsmWrite(tostr(ord(pai_string(hp)^.str[i])));
+                                      end;
+                               end; { end for i:=0 to... }
+                             if quoted then AsmWrite('"');
+                               AsmWrite(target_info.newline);
+                             counter := counter+line_length;
+                          end; { end for j:=0 ... }
+                        { do last line of lines }
+                        AsmWrite(#9#9'DB'#9);
+                        quoted:=false;
+                        for i:=counter to pai_string(hp)^.len-1 do
+                          begin
+                            { it is an ascii character. }
+                            if (ord(pai_string(hp)^.str[i])>31) and
+                               (ord(pai_string(hp)^.str[i])<128) and
+                               (pai_string(hp)^.str[i]<>'"') then
+                                begin
+                                  if not(quoted) then
+                                      begin
+                                        if i>counter then
+                                          AsmWrite(',');
+                                        AsmWrite('"');
+                                      end;
+                                  AsmWrite(pai_string(hp)^.str[i]);
+                                  quoted:=true;
+                                end { if > 31 and < 128 and " }
+                            else
+                                begin
+                                  if quoted then
+                                    AsmWrite('"');
+                                  if i>counter then
+                                      AsmWrite(',');
+                                  quoted:=false;
+                                  AsmWrite(tostr(ord(pai_string(hp)^.str[i])));
+                                end;
+                          end; { end for i:=0 to... }
+                        if quoted then
+                          AsmWrite('"');
+                        end;
+                       AsmLn;
+                     end;
+         ait_label : begin
+                       AsmWrite(lab2str(pai_label(hp)^.l));
+                       if (current_module^.output_format in [of_obj,of_nasm]) or
+                          (assigned(hp^.next) and not(pai(hp^.next)^.typ in
+                           [ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_const_symbol,
+                            ait_real_32bit,ait_real_64bit,ait_real_extended,ait_string])) then
+                        AsmWriteLn(':');
+                     end;
+        ait_direct : begin
+                       AsmWritePChar(pai_direct(hp)^.str);
+                       AsmLn;
+                     end;
+ait_labeled_instruction :
+                     begin
+                       if (current_module^.output_format in [of_nasm,of_obj]) and
+                          not (pai_labeled(hp)^._operator in [A_JMP,A_LOOP,A_LOOPZ,A_LOOPE,
+                          A_LOOPNZ,A_LOOPNE,A_JCXZ,A_JECXZ]) then
+                        AsmWriteLn(#9#9+int_op2str[pai_labeled(hp)^._operator]+#9+'near '+lab2str(pai_labeled(hp)^.lab))
+                       else
+                        AsmWriteLn(#9#9+int_op2str[pai_labeled(hp)^._operator]+#9+lab2str(pai_labeled(hp)^.lab));
+                     end;
+        ait_symbol : begin
+                       if pai_symbol(hp)^.is_global then
+                        begin
+                          if current_module^.output_format in [of_nasm,of_obj] then
+                           AsmWriteLn('GLOBAL '+StrPas(pai_symbol(hp)^.name))
+                          else
+                           AsmWriteLn(#9#9'PUBLIC'#9+StrPas(pai_symbol(hp)^.name));
+                        end;
+                       AsmWritePChar(pai_symbol(hp)^.name);
+                       if assigned(hp^.next) and not(pai(hp^.next)^.typ in
+                        [ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_const_symbol,
+                         ait_real_64bit,ait_string]) then
+                        AsmWriteLn(':')
+                     end;
+   ait_instruction : begin
+                       suffix:='';
+                       { added prefix instructions      }
+                       { must be on same line as opcode }
+                       if (pai386(hp)^.op1t = top_none) and
+                          ((pai386(hp)^._operator = A_REP) or
+                           (pai386(hp)^._operator = A_LOCK) or
+                           (pai386(hp)^._operator =  A_REPE) or
+                           (pai386(hp)^._operator = A_REPNE)) then
+                        Begin
+                          prefix:=int_op2str[pai386(hp)^._operator]+' ';
+                          hp:=Pai(hp^.next);
+                        { this is theorically impossible... }
+                          if hp=nil then
+                           begin
+                             s:=#9#9+prefix;
+                             AsmWriteLn(s);
+                             break;
+                           end;
+                        end
+                       else
+                        prefix:= '';
+                       if pai386(hp)^.op1t<>top_none then
+                        begin
+                          if pai386(hp)^._operator in [A_CALL] then
+                           begin
+                             if output_format=of_nasm then
+                              s:=getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1)
+                             else
+                              s:='near ptr '+getopstr_jmp(pai386(hp)^.op1t,pai386(hp)^.op1);
+                           end
+                          else
+                           begin
+                             s:=getopstr(pai386(hp)^.op1t,pai386(hp)^.op1,pai386(hp)^.size,pai386(hp)^._operator,false);
+                             if pai386(hp)^.op3t<>top_none then
+                              begin
+                                if pai386(hp)^.op2t<>top_none then
+                                 s:=getopstr(pai386(hp)^.op2t,pointer(longint(twowords(pai386(hp)^.op2).word1)),
+                                             pai386(hp)^.size,pai386(hp)^._operator,true)+','+s;
+                                          s:=getopstr(pai386(hp)^.op3t,pointer(longint(twowords(pai386(hp)^.op2).word2)),
+                                           pai386(hp)^.size,pai386(hp)^._operator,false)+','+s;
+                              end
+                             else
+                              if pai386(hp)^.op2t<>top_none then
+                               s:=getopstr(pai386(hp)^.op2t,pai386(hp)^.op2,pai386(hp)^.size,
+                                           pai386(hp)^._operator,true)+','+s;
+                           end;
+                          s:=#9+s;
+                        end
+                       else
+                        begin
+                          { check if string instruction }
+                          { long form, otherwise may give range check errors }
+                          { in turbo pascal...                               }
+                          if ((pai386(hp)^._operator = A_CMPS) or
+                             (pai386(hp)^._operator = A_INS) or
+                             (pai386(hp)^._operator = A_OUTS) or
+                             (pai386(hp)^._operator = A_SCAS) or
+                             (pai386(hp)^._operator = A_STOS) or
+                             (pai386(hp)^._operator = A_MOVS) or
+                             (pai386(hp)^._operator = A_LODS) or
+                             (pai386(hp)^._operator = A_XLAT)) then
+                           Begin
+                             case pai386(hp)^.size of
+                              S_B: suffix:='b';
+                              S_W: suffix:='w';
+                              S_L: suffix:='d';
+                             else
+                              Message(assem_f_invalid_suffix_intel);
+                           end;
+                         end;
+                        s:='';
+                      end;
+                     AsmWriteLn(#9#9+int_op2str[pai386(hp)^._operator]+s);
+                   end;
+{$ifdef GDB}
+             ait_stabn,
+             ait_stabs,
+ait_stab_function_name : ;
+{$endif GDB}
+         else
+          internalerror(10000);
+         end;
+       { we only write a line if not a variable otherwise might }
+       { cause some problems.                                   }
+  {     if ((hp^.typ<>ait_label) and (hp^.typ<>ait_symbol)) or
+           (assigned(hp^.next) and not(pai(hp^.next)^.typ in
+          [ait_const_32bit,ait_const_16bit,ait_const_8bit,
+           ait_const_symbol,ait_real_64bit,ait_real_extended,ait_string,ait_comp])) then
+             AsmWrite(target_info.newline);}
+         hp:=pai(hp^.next);
+       end;
+    end;
+
+
+    procedure ti386intasmlist.WriteAsmList;
+    begin
+{$ifdef EXTDEBUG}
+      if assigned(current_module^.mainsource) then
+       comment(v_info,'Start writing intel-styled assembler output for '+current_module^.mainsource^);
+{$endif}
+      if current_module^.output_format in [of_nasm,of_obj] then
+       begin
+         WriteTree(externals);
+         { INTEL ASM doesn't support stabs
+         WriteTree(debuglist);}
+
+         AsmWriteLn('BITS 32');
+         AsmWriteLn('SECTION .text');
+         {
+         AsmWriteLn(#9#9'ASSUME'#9'CS:_TEXT,ES:DGROUP,DS:DGROUP,SS:DGROUP');
+         }
+         WriteTree(codesegment);
+
+         AsmLn;
+         AsmWriteLn('SECTION .data');
+{$ifdef EXTDEBUG}
+         AsmWriteLn(#9#9'DB'#9'"compiled by FPC '+version_string+'\0"');
+         AsmWriteLn(#9#9'DB'#9'"target: '+target_info.target_name+'\0"');
+{$endif EXTDEBUG}
+         WriteTree(datasegment);
+         WriteTree(consts);
+
+         AsmLn;
+         AsmWriteLn('SECTION .bss');
+         WriteTree(bsssegment);
+       end
+      else
+       begin
+         AsmWriteLn('.386p');
+
+         WriteTree(externals);
+         { INTEL ASM doesn't support stabs
+         WriteTree(debuglist);}
+
+         AsmWriteLn('DGROUP'#9#9'GROUP'#9'_BSS,_DATA');
+         AsmWriteLn('_TEXT'#9#9'SEGMENT'#9'BYTE PUBLIC USE32 ''CODE''');
+         AsmWriteLn(#9#9'ASSUME'#9'CS:_TEXT,ES:DGROUP,DS:DGROUP,SS:DGROUP');
+         AsmLn;
+         WriteTree(codesegment);
+         AsmWriteLn('_TEXT'#9#9'ENDS');
+
+         AsmLn;
+         AsmWriteLn('_DATA'#9#9'SEGMENT'#9'DWORD PUBLIC USE32 ''DATA''');
+{$ifdef EXTDEBUG}
+         AsmWriteLn(#9#9'DB'#9'"compiled by FPC '+version_string+'\0"');
+         AsmWriteLn(#9#9'DB'#9'"target: '+target_info.target_name+'\0"');
+{$endif EXTDEBUG}
+         WriteTree(datasegment);
+         WriteTree(consts);
+         AsmWriteLn('_DATA'#9#9'ENDS');
+
+         AsmLn;
+         AsmWriteLn('_BSS'#9#9'SEGMENT'#9'DWORD PUBLIC USE32 ''BSS''');
+         WriteTree(bsssegment);
+         AsmWriteLn('_BSS'#9#9'ENDS');
+
+         AsmLn;
+         AsmWriteLn(#9#9'END');
+      end;
+{$ifdef EXTDEBUG}
+      if assigned(current_module^.mainsource) then
+       comment(v_info,'Done writing intel-styled assembler output for '+current_module^.mainsource^);
+{$endif EXTDEBUG}
+   end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:16  root
+  Initial revision
+
+  Revision 1.1  1998/03/10 01:26:09  peter
+    + new uniform names
+
+  Revision 1.18  1998/03/09 12:58:11  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.17  1998/03/06 00:52:23  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.16  1998/03/02 01:48:41  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/23 02:57:41  carl
+    * small bugfix when compiling $extdebug
+
+  Revision 1.14  1998/02/15 21:16:20  peter
+    * all assembler outputs supported by assemblerobject
+    * cleanup with assembleroutputs, better .ascii generation
+    * help_constructor/destructor are now added to the externals
+    - generation of asmresponse is not outputformat depended
+
+  Revision 1.13  1998/02/13 10:35:07  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.12  1998/02/12 17:19:07  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.11  1998/02/12 11:50:11  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.10  1997/12/13 18:59:48  florian
+  + I/O streams are now also declared as external, if neccessary
+  * -Aobj generates now a correct obj file via nasm
+
+  Revision 1.9  1997/12/12 13:28:26  florian
+  + version 0.99.0
+  * all WASM options changed into MASM
+  + -O2 for Pentium II optimizations
+
+  Revision 1.8  1997/12/09 13:45:10  carl
+  * bugfix of DT under nasm (not allowed if non integral - nasm v095)
+  + added pai_align --> useless here see file for more info
+  * bugfix of problems with in,out instructions under nasm
+  * bugfix of call under nasm (not fully tested though -- not sure)
+  * some range check errors removed (probably a few left though)
+  * bugfix of checking for extended type when emitting ':'
+
+  Revision 1.7  1997/12/04 15:20:47  carl
+  * esthetic bugfix with extdebug on.
+
+  Revision 1.6  1997/12/03 13:46:40  carl
+  * bugfix of my bug with near, now near in nasm mode for all non-rel8
+  instructions. (jcxz,jecxz still does not work thoug - assumed short now).
+
+  Revision 1.5  1997/12/02 15:52:26  carl
+  * bugfix of string (again...) - would be sometimes invalid.
+  * bugfix of segment overrides under nasm.
+  - removed near in labeled instructions (would cause errors).
+
+  Revision 1.4  1997/12/01 17:42:51  pierre
+     + added some more functionnality to the assembler parser
+
+  Revision 1.3  1997/11/28 18:14:36  pierre
+   working version with several bug fixes
+
+  Revision 1.2  1997/11/28 14:54:50  carl
+  + added popfd instruction.
+
+  Revision 1.1.1.1  1997/11/27 08:32:57  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
+
+  History:
+
+     9th october 1997:
+      * bugfix of string write, closing quotes would never be written. (CEC)
+    23 october 1997:
+      * fixed problem with writing strings of length = 0 (CEC).
+      + added line separation of long string chains. (CEC).
+    31st october 1997:
+      + completed the table of opcodes. (CEC)
+     3rd november 1997:
+      + MMX instructions added (FK)
+     9th november 1997:
+      * movsb represented the AT&T movsx - fixed, absolute values
+        in getreferencestring would be preceded by $ - fixed (CEC).
+
+  What's to do:
+    o Fix problems regarding the segment names under NASM
+    o generate extern entries for typed constants and variables
+    o write lines numbers and file names to output file
+    o comments
+}

compiler/ag68kgas.pas

@@ -0,0 +1,680 @@
+{
+    $Id$
+    Copyright (c) 1998 by the FPC development team
+
+    This unit implements an asmoutput class for MOTOROLA syntax with
+    Motorola 68000 (for GAS v2.52 AND HIGER)
+
+    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.
+
+ ****************************************************************************
+
+  What's to do:
+    o Verify if this actually work as indirect mode with name of variables
+    o write lines numbers and file names to output file
+    o generate debugging informations
+}
+unit ag68kgas;
+
+    interface
+
+    uses aasm,assemble;
+
+    type
+      pm68kgasasmlist=^tm68kgasasmlist;
+      tm68kgasasmlist = object(tasmlist)
+        procedure WriteTree(p:paasmoutput);virtual;
+        procedure WriteAsmList;virtual;
+      end;
+
+   implementation
+
+    uses
+      dos,globals,systems,cobjects,m68k,
+      strings,files,verbose
+{$ifdef GDB}
+      ,gdb
+{$endif GDB}
+      ;
+
+    const
+      line_length = 70;
+
+    var
+      infile : pextfile;
+      includecount,lastline : longint;
+
+    function getreferencestring(const ref : treference) : string;
+      var
+         s : string;
+      begin
+         s:='';
+         if ref.isintvalue then
+             s:='#'+tostr(ref.offset)
+         else
+           with ref do
+             begin
+                if assigned(symbol) then
+                  s:=s+symbol^;
+
+                if offset<0 then s:=s+tostr(offset)
+                  else if (offset>0) then
+                    begin
+                       if (symbol=nil) then s:=tostr(offset)
+                       else s:=s+'+'+tostr(offset);
+                    end;
+               if (index<>R_NO) and (base=R_NO) and (direction=dir_none) then
+                begin
+                  if (scalefactor = 1) or (scalefactor = 0) then
+                    s:=s+'(,'+gas_reg2str[index]+'.l)'
+                  else
+                    s:=s+'(,'+gas_reg2str[index]+'.l*'+tostr(scalefactor)+')'
+                end
+                else if (index=R_NO) and (base<>R_NO) and (direction=dir_inc) then
+                begin
+                  if (scalefactor = 1) or (scalefactor = 0) then
+                      s:=s+'('+gas_reg2str[base]+')+'
+                  else
+                   InternalError(10002);
+                end
+                else if (index=R_NO) and (base<>R_NO) and (direction=dir_dec) then
+                begin
+                  if (scalefactor = 1) or (scalefactor = 0) then
+                      s:=s+'-('+gas_reg2str[base]+')'
+                  else
+                   InternalError(10003);
+                end
+                  else if (index=R_NO) and (base<>R_NO) and (direction=dir_none) then
+                begin
+                  s:=s+'('+gas_reg2str[base]+')'
+                end
+                  else if (index<>R_NO) and (base<>R_NO) and (direction=dir_none) then
+                begin
+                  if (scalefactor = 1) or (scalefactor = 0) then
+                    s:=s+'('+gas_reg2str[base]+','+gas_reg2str[index]+'.l)'
+                  else
+                    s:=s+'('+gas_reg2str[base]+','+gas_reg2str[index]+'.l*'+tostr(scalefactor)+')';
+                end;
+            end; { end with }
+         getreferencestring:=s;
+      end;
+
+    function getopstr(t : byte;o : pointer) : string;
+
+      var
+         hs : string;
+         i: tregister;
+
+      begin
+         case t of
+            top_reg : getopstr:=gas_reg2str[tregister(o)];
+               top_ref : getopstr:=getreferencestring(preference(o)^);
+         top_reglist: begin
+                      hs:='';
+                      for i:=R_NO to R_FPSR do
+                      begin
+                        if i in tregisterlist(o^) then
+                         hs:=hs+gas_reg2str[i]+'/';
+                      end;
+                      delete(hs,length(hs),1);
+                      getopstr := hs;
+                    end;
+             top_const : getopstr:='#'+tostr(longint(o));
+            top_symbol :
+                    { compare with i386, where a symbol is considered }
+                    { a constant.                                     }
+                    begin
+                     hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
+                            move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
+{                           inc(byte(hs[0]));}
+                            if pcsymbol(o)^.offset>0 then
+                              hs:=hs+'+'+tostr(pcsymbol(o)^.offset)
+                            else if pcsymbol(o)^.offset<0 then
+                              hs:=hs+tostr(pcsymbol(o)^.offset);
+                            getopstr:=hs;
+                         end;
+            else internalerror(10001);
+         end;
+      end;
+
+    function getopstr_jmp(t : byte;o : pointer) : string;
+
+      var
+         hs : string;
+
+      begin
+         case t of
+            top_reg : getopstr_jmp:=gas_reg2str[tregister(o)];
+            top_ref : getopstr_jmp:=getreferencestring(preference(o)^);
+            top_const : getopstr_jmp:=tostr(longint(o));
+            top_symbol : begin
+                            hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
+                            move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
+                            if pcsymbol(o)^.offset>0 then
+                              hs:=hs+'+'+tostr(pcsymbol(o)^.offset)
+                            else if pcsymbol(o)^.offset<0 then
+                              hs:=hs+tostr(pcsymbol(o)^.offset);
+                            getopstr_jmp:=hs;
+                         end;
+            else internalerror(10001);
+         end;
+      end;
+
+{****************************************************************************
+                             T68kGASASMOUTPUT
+ ****************************************************************************}
+
+    var
+       { different types of source lines }
+       n_line : byte;
+
+    const
+      ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]=
+        (#9'.long'#9,'',#9'.short'#9,#9'.byte'#9);
+
+    procedure tm68kgasasmlist.WriteTree(p:paasmoutput);
+    var
+      hp        : pai;
+      ch        : char;
+      consttyp  : tait;
+      s         : string;
+      pos,l,i   : longint;
+      found     : boolean;
+{$ifdef GDB}
+      funcname  : pchar;
+      linecount : longint;
+{$endif GDB}
+    begin
+{$ifdef GDB}
+      funcname:=nil;
+      linecount:=1;
+{$endif GDB}
+      hp:=pai(p^.first);
+      while assigned(hp) do
+       begin
+       { write debugger informations }
+{$ifdef GDB}
+         if cs_debuginfo in aktswitches then
+          begin
+            if not (hp^.typ in  [ait_external,ait_stabn,ait_stabs,ait_stab_function_name]) then
+             begin
+               if assigned(hp^.infile) and (pextfile(hp^.infile)<>infile)  then
+                begin
+                  infile:=hp^.infile;
+                  inc(includecount);
+                  if (hp^.infile^.path^<>'') then
+                   begin
+                     AsmWriteLn(#9'.stabs "'+FixPath(hp^.infile^.path^)+'",'+tostr(n_includefile)+
+                                ',0,0,Ltext'+ToStr(IncludeCount));
+                   end;
+                  AsmWriteLn(#9'.stabs "'+FixFileName(hp^.infile^.name^+hp^.infile^.ext^)+'",'+tostr(n_includefile)+
+                             ',0,0,Ltext'+ToStr(IncludeCount));
+                  AsmWriteLn('Ltext'+ToStr(IncludeCount)+':');
+                end;
+              { file name must be there before line number ! }
+               if (hp^.line<>lastline) and (hp^.line<>0) then
+                begin
+                  if (n_line = n_textline) and assigned(funcname) and
+                     (target_info.use_function_relative_addresses) then
+                   begin
+                     AsmWriteLn(target_info.labelprefix+'l'+tostr(linecount)+':');
+                     AsmWriteLn(#9'.stabn '+tostr(n_line)+',0,'+tostr(hp^.line)+','+
+                                target_info.labelprefix+'l'+tostr(linecount)+' - '+StrPas(FuncName));
+                     inc(linecount);
+                   end
+                  else
+                   AsmWriteLn(#9'.stabd'#9+tostr(n_line)+',0,'+tostr(hp^.line));
+                  lastline:=hp^.line;
+                end;
+             end;
+          end;
+{$endif GDB}
+
+         case hp^.typ of
+       ait_comment,
+      ait_external : ; { external is ignored }
+         ait_align : AsmWriteLn(#9'.align '+tostr(pai_align(hp)^.aligntype));
+     ait_datablock : begin
+                       { ------------------------------------------------------- }
+                       { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- }
+                       { ------------- REQUIREMENT FOR 680x0 ------------------- }
+                       { ------------------------------------------------------- }
+                       if pai_datablock(hp)^.size <> 1 then
+                        begin
+                          if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                          else
+                           AsmWriteLn(#9#9'.align 2');
+                        end;
+                       if pai_datablock(hp)^.is_global then
+                        AsmWrite(#9'.comm'#9)
+                       else
+                        AsmWrite(#9'.lcomm'#9);
+                       AsmWriteLn(StrPas(pai_datablock(hp)^.name)+','+tostr(pai_datablock(hp)^.size));
+                     end;
+   ait_const_32bit, { alignment is required for 16/32 bit data! }
+   ait_const_16bit:  begin
+                      if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                      else
+                          AsmWriteLn(#9#9'.align 2');
+                       AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value));
+                       consttyp:=hp^.typ;
+                       l:=0;
+                       repeat
+                         found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp);
+                         if found then
+                          begin
+                            hp:=Pai(hp^.next);
+                            s:=','+tostr(pai_const(hp)^.value);
+                            AsmWrite(s);
+                            inc(l,length(s));
+                          end;
+                       until (not found) or (l>line_length);
+                       AsmLn;
+                     end;
+    ait_const_8bit : begin
+                       AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value));
+                       consttyp:=hp^.typ;
+                       l:=0;
+                       repeat
+                         found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp);
+                         if found then
+                          begin
+                            hp:=Pai(hp^.next);
+                            s:=','+tostr(pai_const(hp)^.value);
+                            AsmWrite(s);
+                            inc(l,length(s));
+                          end;
+                       until (not found) or (l>line_length);
+                       AsmLn;
+                     end;
+  ait_const_symbol : Begin
+                      if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                      else
+                          AsmWriteLn(#9#9'.align 2');
+                       AsmWriteLn(#9'.long'#9+StrPas(pchar(pai_const(hp)^.value)));
+                     end;
+    ait_real_64bit : Begin
+                      if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                      else
+                          AsmWriteLn(#9#9'.align 2');
+                      AsmWriteLn(#9'.double'#9+double2str(pai_double(hp)^.value));
+                     end;
+    ait_real_32bit : Begin
+                      if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                      else
+                          AsmWriteLn(#9#9'.align 2');
+                      AsmWriteLn(#9'.single'#9+double2str(pai_single(hp)^.value));
+                     end;
+ ait_real_extended : Begin
+                      if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                      else
+                          AsmWriteLn(#9#9'.align 2');
+                      AsmWriteLn(#9'.extend'#9+double2str(pai_extended(hp)^.value));
+                     { comp type is difficult to write so use double }
+                     end;
+          ait_comp : Begin
+                      if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                      else
+                          AsmWriteLn(#9#9'.align 2');
+                       AsmWriteLn(#9'.double'#9+comp2str(pai_extended(hp)^.value));
+                     end;
+        ait_direct : begin
+                       AsmWritePChar(pai_direct(hp)^.str);
+                       AsmLn;
+{$IfDef GDB}
+                       if strpos(pai_direct(hp)^.str,'.data')<>nil then
+                         n_line:=n_dataline
+                       else if strpos(pai_direct(hp)^.str,'.text')<>nil then
+                         n_line:=n_textline
+                       else if strpos(pai_direct(hp)^.str,'.bss')<>nil then
+                         n_line:=n_bssline;
+{$endif GDB}
+                     end;
+        ait_string : begin
+                       pos:=0;
+                       for i:=1 to pai_string(hp)^.len do
+                        begin
+                          if pos=0 then
+                           begin
+                             AsmWrite(#9'.ascii'#9'"');
+                             pos:=20;
+                           end;
+                          ch:=pai_string(hp)^.str[i-1];
+                          case ch of
+                             #0, {This can't be done by range, because a bug in FPC}
+                        #1..#31,
+                     #128..#255 : s:='\'+tostr(ord(ch) shr 6)+tostr((ord(ch) and 63) shr 3)+tostr(ord(ch) and 7);
+                            '"' : s:='\"';
+                            '\' : s:='\\';
+                          else
+                           s:=ch;
+                          end;
+                          AsmWrite(s);
+                          inc(pos,length(s));
+                          if (pos>line_length) or (i=pai_string(hp)^.len) then
+                           begin
+                             AsmWriteLn('"');
+                             pos:=0;
+                           end;
+                        end;
+                     end;
+         ait_label : begin
+                       if (pai_label(hp)^.l^.is_used) then
+                        AsmWriteLn(lab2str(pai_label(hp)^.l)+':');
+                     end;
+ait_labeled_instruction : begin
+                     { labeled operand }
+                       if pai_labeled(hp)^._op1 = R_NO then
+                        AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+lab2str(pai_labeled(hp)^.lab))
+                       else
+                     { labeled operand with register }
+                        AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+
+                                 reg2str(pai_labeled(hp)^._op1)+','+lab2str(pai_labeled(hp)^.lab))
+                     end;
+        ait_symbol : begin
+                       { ------------------------------------------------------- }
+                       { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- }
+                       { ------------- REQUIREMENT FOR 680x0 ------------------- }
+                       { ------------------------------------------------------- }
+                       if assigned(hp^.next) and (pai(hp^.next)^.typ in
+                          [ait_const_32bit,ait_const_16bit,ait_const_symbol,
+                           ait_real_64bit,ait_real_32bit,ait_string]) then
+                        begin
+                          if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                          else
+                           AsmWriteLn(#9#9'.align 2');
+                        end;
+                       if pai_symbol(hp)^.is_global then
+                        AsmWriteLn('.globl '+StrPas(pai_symbol(hp)^.name));
+                       AsmWriteLn(StrPas(pai_symbol(hp)^.name)+':');
+                     end;
+   ait_instruction : begin
+                       { old versions of GAS don't like PEA.L and LEA.L }
+                       if (pai68k(hp)^._operator <> A_LEA) and (pai68k(hp)^._operator<> A_PEA) then
+                           s:=#9+mot_op2str[pai68k(hp)^._operator]+gas_opsize2str[pai68k(hp)^.size]
+                       else
+                           s:=#9+mot_op2str[pai68k(hp)^._operator];
+                       if pai68k(hp)^.op1t<>top_none then
+                        begin
+                        { call and jmp need an extra handling                          }
+                        { this code is only callded if jmp isn't a labeled instruction }
+                          if pai68k(hp)^._operator in [A_JSR,A_JMP] then
+                           s:=s+#9+getopstr_jmp(pai68k(hp)^.op1t,pai68k(hp)^.op1)
+                          else
+                           if pai68k(hp)^.op1t = top_reglist then
+                            s:=s+#9+getopstr(pai68k(hp)^.op1t,@(pai68k(hp)^.reglist))
+                           else
+                            s:=s+#9+getopstr(pai68k(hp)^.op1t,pai68k(hp)^.op1);
+                           if pai68k(hp)^.op2t<>top_none then
+                            begin
+                              if pai68k(hp)^.op2t = top_reglist then
+                               s:=s+','+getopstr(pai68k(hp)^.op2t,@pai68k(hp)^.reglist)
+                              else
+                               s:=s+','+getopstr(pai68k(hp)^.op2t,pai68k(hp)^.op2);
+                            { three operands }
+                              if pai68k(hp)^.op3t<>top_none then
+                               begin
+                                   if (pai68k(hp)^._operator = A_DIVSL) or
+                                      (pai68k(hp)^._operator = A_DIVUL) or
+                                      (pai68k(hp)^._operator = A_MULU) or
+                                      (pai68k(hp)^._operator = A_MULS) or
+                                      (pai68k(hp)^._operator = A_DIVS) or
+                                      (pai68k(hp)^._operator = A_DIVU) then
+                                    s:=s+':'+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3)
+                                   else
+                                    s:=s+','+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3);
+                               end;
+                            end;
+                        end;
+                       AsmWriteLn(s);
+                     end;
+{$ifdef GDB}
+         ait_stabs : begin
+                       AsmWrite(#9'.stabs ');
+                       AsmWritePChar(pai_stabs(hp)^.str);
+                       AsmLn;
+                     end;
+         ait_stabn : begin
+                       AsmWrite(#9'.stabn ');
+                       AsmWritePChar(pai_stabn(hp)^.str);
+                       AsmLn;
+                     end;
+ait_stab_function_name : funcname:=pai_stab_function_name(hp)^.str;
+{$endif GDB}
+         else
+          internalerror(10000);
+         end;
+         hp:=pai(hp^.next);
+       end;
+    end;
+
+    procedure tm68kgasasmlist.WriteAsmList;
+{$ifdef GDB}
+    var
+      p,n,e : string;
+{$endif}
+    begin
+{$ifdef EXTDEBUG}
+      if assigned(current_module^.mainsource) then
+       comment(v_info,'Start writing gas-styled assembler output for '+current_module^.mainsource^);
+{$endif}
+      infile:=nil;
+      includecount:=0;
+{$ifdef GDB}
+      if assigned(current_module^.mainsource) then
+       fsplit(current_module^.mainsource^,p,n,e)
+      else
+       begin
+         p:=inputdir;
+         n:=inputfile;
+         e:=inputextension;
+       end;
+    { to get symify to work }
+      AsmWriteLn(#9'.file "'+FixFileName(n+e)+'"');
+    { stabs }
+      n_line:=n_bssline;
+      if (cs_debuginfo in aktswitches) then
+       begin
+         if (p<>'') then
+          AsmWriteLn(#9'.stabs "'+FixPath(p)+'",'+tostr(n_sourcefile)+',0,0,Ltext0');
+         AsmWriteLn(#9'.stabs "'+FixFileName(n+e)+'",'+tostr(n_sourcefile)+',0,0,Ltext0');
+         AsmWriteLn('Ltext0:');
+       end;
+      infile:=current_module^.sourcefiles.files;
+{$endif GDB}
+
+    { main source file is last in list }
+      while assigned(infile^._next) do
+       infile:=infile^._next;
+      lastline:=0;
+      { there should be nothing but externals so we don't need to process
+      WriteTree(externals); }
+      WriteTree(debuglist);
+
+    { code segment }
+      AsmWriteln('.text');
+{$ifdef GDB}
+      n_line:=n_textline;
+{$endif GDB}
+      WriteTree(codesegment);
+
+      AsmWriteLn('.data');
+{$ifdef EXTDEBUG}
+      AsmWriteLn(#9'.ascii'#9'"compiled by FPC '+version_string+'\0"');
+      AsmWriteLn(#9'.ascii'#9'"target: '+target_info.target_name+'\0"');
+{$endif EXTDEBUG}
+{$ifdef GDB}
+      n_line:=n_dataline;
+{$endif GDB}
+      DataSegment^.insert(new(pai_align,init(4)));
+      WriteTree(datasegment);
+      WriteTree(consts);
+
+    { makes problems with old GNU ASes
+      AsmWriteLn('.bss');
+      bssSegment^.insert(new(pai_align,init(4))); }
+{$ifdef GDB}
+      n_line:=n_bssline;
+{$endif GDB}
+      WriteTree(bsssegment);
+
+      AsmLn;
+{$ifdef EXTDEBUG}
+      if assigned(current_module^.mainsource) then
+       comment(v_info,'Done writing gas-styled assembler output for '+current_module^.mainsource^);
+{$endif EXTDEBUG}
+    end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:16  root
+  Initial revision
+
+  Revision 1.3  1998/03/22 12:45:37  florian
+    * changes of Carl-Eric to m68k target commit:
+      - wrong nodes because of the new string cg in intel, I had to create
+        this under m68k also ... had to work it out to fix potential alignment
+        problems --> this removes the crash of the m68k compiler.
+      - added absolute addressing in m68k assembler (required for Amiga startup)
+      - fixed alignment problems (because of byte return values, alignment
+        would not be always valid) -- is this ok if i change the offset if odd in
+        setfirsttemp ?? -- it seems ok...
+
+  Revision 1.2  1998/03/10 04:22:08  carl
+    - removed in as it can cause range check errors under BP
+
+  Revision 1.1  1998/03/10 01:26:10  peter
+    + new uniform names
+
+  Revision 1.18  1998/03/09 12:58:10  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.17  1998/03/06 00:52:18  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.16  1998/03/02 01:48:33  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/23 03:00:00  carl
+    * bugfix when compiling with extdebug defined
+
+  Revision 1.14  1998/02/22 23:03:18  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.13  1998/02/21 20:20:52  carl
+     * make it work under older versions of GAS
+
+  Revision 1.10  1998/02/15 21:16:19  peter
+    * all assembler outputs supported by assemblerobject
+    * cleanup with assembleroutputs, better .ascii generation
+    * help_constructor/destructor are now added to the externals
+    - generation of asmresponse is not outputformat depended
+
+  Revision 1.9  1998/02/13 10:34:59  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.8  1998/02/12 11:50:04  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.7  1998/01/09 19:20:49  carl
+  + added support for mul/div 68020 syntax
+  * bugfix of getreferencestring
+
+  Revision 1.4  1997/12/09 13:37:50  carl
+  + ait_align added
+  * now all non byte values are aligned correctly
+
+  Revision 1.3  1997/12/05 14:40:49  carl
+  * bugfix of scaling, was incorrect under gas.
+
+  Revision 1.2  1997/12/04 15:30:14  carl
+  * forgot to change name of unit! ugh...
+
+  Revision 1.1  1997/12/03 14:04:19  carl
+  + renamed from gasasm6.pas to ag68kgas.pas
+
+  Revision 1.3  1997/12/01 17:42:51  pierre
+     + added some more functionnality to the assembler parser
+
+  Revision 1.2  1997/11/28 18:14:32  pierre
+   working version with several bug fixes
+
+  Revision 1.1.1.1  1997/11/27 08:32:56  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
+
+  History:
+      30th september 1996:
+         + unit started (FK)
+      15th october 1996:
+         + ti386attasmoutput class started (FK)
+      28th november 1996:
+         ! debugging for simple programs (FK)
+      26th february 1997:
+         + op2str array completed with work of Daniel Manitone (FK)
+      25th september 1997:
+         * compiled by comment ifdef'ed (FK)
+      4th october 1997:
+         + converted to motorola 68000 (same sytnax as gas) (CEC)
+     9th october 1997:
+       * fixed constant bug. (CEC)
+       + converted from %reg to reg (untested) (CEC)
+     (according to gas docs, they are accepted).
+    28th october 1997:
+       * bugfix on increment/decrement mode (was never checked). (CEC)
+    2nd november 1997:
+       + added all opcodes , and they are now in correct order of
+         processor types. (CEC).
+}

compiler/ag68kmit.pas

@@ -0,0 +1,645 @@
+{
+    $Id$
+    Copyright (c) 1998 by the FPC development team
+
+    This unit implements an asmoutput class for MIT syntax with
+    Motorola 68000 (for MIT syntax TEST WITH GAS v1.34)
+
+    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.
+
+ ****************************************************************************
+
+  What's to do:
+    o Verify if this actually work as indirect mode with name of variables
+    o write lines numbers and file names to output file
+    o generate debugging informations
+}
+
+unit ag68kmit;
+
+    interface
+
+    uses aasm,assemble;
+
+    type
+      pm68kmitasmlist=^tm68kmitasmlist;
+      tm68kmitasmlist = object(tasmlist)
+        procedure WriteTree(p:paasmoutput);virtual;
+        procedure WriteAsmList;virtual;
+      end;
+
+   implementation
+
+    uses
+      dos,globals,systems,cobjects,m68k,
+      strings,files,verbose
+{$ifdef GDB}
+      ,gdb
+{$endif GDB}
+      ;
+
+    const
+      line_length = 70;
+
+    var
+      infile : pextfile;
+      includecount,lastline : longint;
+
+    function getreferencestring(const ref : treference) : string;
+      var
+         s : string;
+      begin
+         s:='';
+         if ref.isintvalue then
+             s:='#'+tostr(ref.offset)
+         else
+           with ref do
+             begin
+                  { symbol and offset }
+                  if (assigned(symbol)) and (offset<>0) then
+                    Begin
+                      s:=s+'('+tostr(offset)+symbol^;
+                    end
+                  else
+                  { symbol only }
+                  if (assigned(symbol)) and (offset=0) then
+                    Begin
+                      s:=s+'('+symbol^;
+                    end
+                  else
+                  { offset only }
+                  if (symbol=nil) and (offset<>0) then
+                    Begin
+                      s:=s+'('+tostr(offset);
+                    end
+                  else
+                  { NOTHING - put zero as offset }
+                  if (symbol=nil) and (offset=0) then
+                    Begin
+                      s:=s+'('+'0';
+                    end
+                  else
+                   InternalError(10004);
+                  if (index<>R_NO) and (base=R_NO) and (direction=dir_none) then
+                   InternalError(10004)
+                else if (index=R_NO) and (base<>R_NO) and (direction=dir_inc) then
+                begin
+                  if (scalefactor = 1) or (scalefactor = 0) then
+                    Begin
+                      if offset<>0 then
+                        s:=mit_reg2str[base]+'@+'+s+')'
+                      else
+                        s:=mit_reg2str[base]+'@+';
+                    end
+                  else
+                   InternalError(10002);
+                end
+                else if (index=R_NO) and (base<>R_NO) and (direction=dir_dec) then
+                begin
+                  if (scalefactor = 1) or (scalefactor = 0) then
+                    Begin
+                      if offset<>0 then
+                         s:=mit_reg2str[base]+'@-'+s+')'
+                      else
+                         s:=mit_reg2str[base]+'@-';
+                    end
+                  else
+                   InternalError(10003);
+                end
+              else if (index=R_NO) and (base<>R_NO) and (direction=dir_none) then
+                begin
+                  if (offset=0) and (symbol=nil) then
+                     s:=mit_reg2str[base]+'@'
+                  else
+                     s:=mit_reg2str[base]+'@'+s+')';
+                end
+              else if (index<>R_NO) and (base<>R_NO) and (direction=dir_none) then
+                begin
+                  s:=mit_reg2str[base]+'@'+s+','+mit_reg2str[index]+':L';
+                  if (scalefactor = 1) or (scalefactor = 0) then
+                      s:=s+')'
+                  else
+                     s:=s+':'+tostr(scalefactor)+')';
+                end
+                else
+                if assigned(symbol) then
+                Begin
+                   s:=symbol^;
+                   if offset<>0 then
+                     s:=s+'+'+tostr(offset);
+                end
+                { this must be a physical address }
+                else
+                  s:=s+')';
+{                else if NOT assigned(symbol) then
+                  InternalError(10004);}
+            end; { end with }
+         getreferencestring:=s;
+      end;
+
+
+    function getopstr(t : byte;o : pointer) : string;
+      var
+         hs : string;
+         i: tregister;
+      begin
+         case t of
+            top_reg : getopstr:=mit_reg2str[tregister(o)];
+               top_ref : getopstr:=getreferencestring(preference(o)^);
+         top_reglist: begin
+                      hs:='';
+                      for i:=R_NO to R_FPSR do
+                      begin
+                        if i in tregisterlist(o^) then
+                         hs:=hs+mit_reg2str[i]+'/';
+                      end;
+                      delete(hs,length(hs),1);
+                      getopstr := hs;
+                    end;
+             top_const : getopstr:='#'+tostr(longint(o));
+            top_symbol :
+                    { compare with i386, where a symbol is considered }
+                    { a constant.                                     }
+                    begin
+                     hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
+                            move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
+{                           inc(byte(hs[0]));}
+                            if pcsymbol(o)^.offset>0 then
+                              hs:=hs+'+'+tostr(pcsymbol(o)^.offset)
+                            else if pcsymbol(o)^.offset<0 then
+                              hs:=hs+tostr(pcsymbol(o)^.offset);
+                            getopstr:=hs;
+                         end;
+            else internalerror(10001);
+         end;
+      end;
+
+
+    function getopstr_jmp(t : byte;o : pointer) : string;
+      var
+         hs : string;
+      begin
+         case t of
+            top_reg : getopstr_jmp:=mit_reg2str[tregister(o)];
+            top_ref : getopstr_jmp:=getreferencestring(preference(o)^);
+            top_const : getopstr_jmp:=tostr(longint(o));
+            top_symbol : begin
+                            hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
+                            move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
+                            if pcsymbol(o)^.offset>0 then
+                              hs:=hs+'+'+tostr(pcsymbol(o)^.offset)
+                            else if pcsymbol(o)^.offset<0 then
+                              hs:=hs+tostr(pcsymbol(o)^.offset);
+                            getopstr_jmp:=hs;
+                         end;
+            else internalerror(10001);
+         end;
+      end;
+
+
+{****************************************************************************
+                             T68kGASASMOUTPUT
+ ****************************************************************************}
+
+    var
+       { different types of source lines }
+       n_line : byte;
+
+    const
+      ait_const2str:array[ait_const_32bit..ait_const_8bit] of string[8]=
+        (#9'.long'#9,'',#9'.short'#9,#9'.byte'#9);
+
+    procedure tm68kmitasmlist.WriteTree(p:paasmoutput);
+    var
+      hp        : pai;
+      ch        : char;
+      consttyp  : tait;
+      s         : string;
+      pos,l,i   : longint;
+      found     : boolean;
+{$ifdef GDB}
+      funcname  : pchar;
+      linecount : longint;
+{$endif GDB}
+    begin
+{$ifdef GDB}
+      funcname:=nil;
+      linecount:=1;
+{$endif GDB}
+      hp:=pai(p^.first);
+      while assigned(hp) do
+       begin
+       { write debugger informations }
+{$ifdef GDB}
+         if cs_debuginfo in aktswitches then
+          begin
+            if not (hp^.typ in  [ait_external,ait_stabn,ait_stabs,ait_stab_function_name]) then
+             begin
+               if assigned(hp^.infile) and (pextfile(hp^.infile)<>infile)  then
+                begin
+                  infile:=hp^.infile;
+                  inc(includecount);
+                  if (hp^.infile^.path^<>'') then
+                   begin
+                     AsmWriteLn(#9'.stabs "'+FixPath(hp^.infile^.path^)+'",'+tostr(n_includefile)+
+                                ',0,0,Ltext'+ToStr(IncludeCount));
+                   end;
+                  AsmWriteLn(#9'.stabs "'+FixFileName(hp^.infile^.name^+hp^.infile^.ext^)+'",'+tostr(n_includefile)+
+                             ',0,0,Ltext'+ToStr(IncludeCount));
+                  AsmWriteLn('Ltext'+ToStr(IncludeCount)+':');
+                end;
+              { file name must be there before line number ! }
+               if (hp^.line<>lastline) and (hp^.line<>0) then
+                begin
+                  if (n_line = n_textline) and assigned(funcname) and
+                     (target_info.use_function_relative_addresses) then
+                   begin
+                     AsmWriteLn(target_info.labelprefix+'l'+tostr(linecount)+':');
+                     AsmWriteLn(#9'.stabn '+tostr(n_line)+',0,'+tostr(hp^.line)+','+
+                                target_info.labelprefix+'l'+tostr(linecount)+' - '+StrPas(FuncName));
+                     inc(linecount);
+                   end
+                  else
+                   AsmWriteLn(#9'.stabd'#9+tostr(n_line)+',0,'+tostr(hp^.line));
+                  lastline:=hp^.line;
+                end;
+             end;
+          end;
+{$endif GDB}
+         case hp^.typ of
+       ait_comment,
+      ait_external : ; { external is ignored }
+         ait_align : AsmWriteLn(#9'.align '+tostr(pai_align(hp)^.aligntype));
+     ait_datablock : begin
+                       { ------------------------------------------------------- }
+                       { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- }
+                       { ------------- REQUIREMENT FOR 680x0 ------------------- }
+                       { ------------------------------------------------------- }
+                       if pai_datablock(hp)^.size <> 1 then
+                        begin
+                          if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                          else
+                           AsmWriteLn(#9#9'.align 2');
+                        end;
+                       if pai_datablock(hp)^.is_global then
+                        AsmWrite(#9'.comm'#9)
+                       else
+                        AsmWrite(#9'.lcomm'#9);
+                       AsmWriteLn(StrPas(pai_datablock(hp)^.name)+','+tostr(pai_datablock(hp)^.size));
+                     end;
+   ait_const_32bit, { alignment is required for 16/32 bit data! }
+   ait_const_16bit:  begin
+                      if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                      else
+                          AsmWriteLn(#9#9'.align 2');
+                       AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value));
+                       consttyp:=hp^.typ;
+                       l:=0;
+                       repeat
+                         found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp);
+                         if found then
+                          begin
+                            hp:=Pai(hp^.next);
+                            s:=','+tostr(pai_const(hp)^.value);
+                            AsmWrite(s);
+                            inc(l,length(s));
+                          end;
+                       until (not found) or (l>line_length);
+                       AsmLn;
+                     end;
+    ait_const_8bit : begin
+                       AsmWrite(ait_const2str[hp^.typ]+tostr(pai_const(hp)^.value));
+                       consttyp:=hp^.typ;
+                       l:=0;
+                       repeat
+                         found:=(not (Pai(hp^.next)=nil)) and (Pai(hp^.next)^.typ=consttyp);
+                         if found then
+                          begin
+                            hp:=Pai(hp^.next);
+                            s:=','+tostr(pai_const(hp)^.value);
+                            AsmWrite(s);
+                            inc(l,length(s));
+                          end;
+                       until (not found) or (l>line_length);
+                       AsmLn;
+                     end;
+  ait_const_symbol : Begin
+                      if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                      else
+                          AsmWriteLn(#9#9'.align 2');
+                       AsmWriteLn(#9'.long'#9+StrPas(pchar(pai_const(hp)^.value)));
+                     end;
+    ait_real_64bit : Begin
+                      if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                      else
+                          AsmWriteLn(#9#9'.align 2');
+                      AsmWriteLn(#9'.double'#9+double2str(pai_double(hp)^.value));
+                     end;
+    ait_real_32bit : Begin
+                      if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                      else
+                          AsmWriteLn(#9#9'.align 2');
+                      AsmWriteLn(#9'.single'#9+double2str(pai_single(hp)^.value));
+                     end;
+ ait_real_extended : Begin
+                      if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                      else
+                          AsmWriteLn(#9#9'.align 2');
+                      AsmWriteLn(#9'.extend'#9+double2str(pai_extended(hp)^.value));
+                     { comp type is difficult to write so use double }
+                     end;
+          ait_comp : Begin
+                      if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                      else
+                          AsmWriteLn(#9#9'.align 2');
+                       AsmWriteLn(#9'.double'#9+comp2str(pai_extended(hp)^.value));
+                     end;
+        ait_direct : begin
+                       AsmWritePChar(pai_direct(hp)^.str);
+                       AsmLn;
+{$IfDef GDB}
+                       if strpos(pai_direct(hp)^.str,'.data')<>nil then
+                         n_line:=n_dataline
+                       else if strpos(pai_direct(hp)^.str,'.text')<>nil then
+                         n_line:=n_textline
+                       else if strpos(pai_direct(hp)^.str,'.bss')<>nil then
+                         n_line:=n_bssline;
+{$endif GDB}
+                     end;
+        ait_string : begin
+                       pos:=0;
+                       for i:=1 to pai_string(hp)^.len do
+                        begin
+                          if pos=0 then
+                           begin
+                             AsmWrite(#9'.ascii'#9'"');
+                             pos:=20;
+                           end;
+                          ch:=pai_string(hp)^.str[i-1];
+                          case ch of
+                             #0, {This can't be done by range, because a bug in FPC}
+                        #1..#31,
+                     #128..#255 : s:='\'+tostr(ord(ch) shr 6)+tostr((ord(ch) and 63) shr 3)+tostr(ord(ch) and 7);
+                            '"' : s:='\"';
+                            '\' : s:='\\';
+                          else
+                           s:=ch;
+                          end;
+                          AsmWrite(s);
+                          inc(pos,length(s));
+                          if (pos>line_length) or (i=pai_string(hp)^.len) then
+                           begin
+                             AsmWriteLn('"');
+                             pos:=0;
+                           end;
+                        end;
+                     end;
+         ait_label : begin
+                       if (pai_label(hp)^.l^.is_used) then
+                        AsmWriteLn(lab2str(pai_label(hp)^.l)+':');
+                     end;
+ait_labeled_instruction : begin
+                     { labeled operand }
+                       if pai_labeled(hp)^._op1 = R_NO then
+                        AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+lab2str(pai_labeled(hp)^.lab))
+                       else
+                     { labeled operand with register }
+                        AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+
+                                 reg2str(pai_labeled(hp)^._op1)+','+lab2str(pai_labeled(hp)^.lab))
+                     end;
+        ait_symbol : begin
+                       { ------------------------------------------------------- }
+                       { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- }
+                       { ------------- REQUIREMENT FOR 680x0 ------------------- }
+                       { ------------------------------------------------------- }
+                       if assigned(hp^.next) and (pai(hp^.next)^.typ in
+                          [ait_const_32bit,ait_const_16bit,ait_const_symbol,
+                           ait_real_64bit,ait_real_32bit,ait_string]) then
+                        begin
+                          if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9#9'.align 4')
+                          else
+                           AsmWriteLn(#9#9'.align 2');
+                        end;
+                       if pai_symbol(hp)^.is_global then
+                        AsmWriteLn('.globl '+StrPas(pai_symbol(hp)^.name));
+                       AsmWriteLn(StrPas(pai_symbol(hp)^.name)+':');
+                     end;
+   ait_instruction : begin
+                       { old versions of GAS don't like PEA.L and LEA.L }
+                       if (pai68k(hp)^._operator in [
+                            A_LEA,A_PEA,A_ABCD,A_BCHG,A_BCLR,A_BSET,A_BTST,
+                            A_EXG,A_NBCD,A_SBCD,A_SWAP,A_TAS,A_SCC,A_SCS,
+                            A_SEQ,A_SGE,A_SGT,A_SHI,A_SLE,A_SLS,A_SLT,A_SMI,
+                            A_SNE,A_SPL,A_ST,A_SVC,A_SVS,A_SF]) then
+                        s:=#9+mot_op2str[pai68k(hp)^._operator]
+                       else
+                        s:=#9+mot_op2str[pai68k(hp)^._operator]+mit_opsize2str[pai68k(hp)^.size];
+                       if pai68k(hp)^.op1t<>top_none then
+                        begin
+                        { call and jmp need an extra handling                          }
+                        { this code is only callded if jmp isn't a labeled instruction }
+                          if pai68k(hp)^._operator in [A_JSR,A_JMP] then
+                           s:=s+#9+getopstr_jmp(pai68k(hp)^.op1t,pai68k(hp)^.op1)
+                          else
+                           if pai68k(hp)^.op1t = top_reglist then
+                            s:=s+#9+getopstr(pai68k(hp)^.op1t,@(pai68k(hp)^.reglist))
+                           else
+                            s:=s+#9+getopstr(pai68k(hp)^.op1t,pai68k(hp)^.op1);
+                           if pai68k(hp)^.op2t<>top_none then
+                            begin
+                              if pai68k(hp)^.op2t = top_reglist then
+                               s:=s+','+getopstr(pai68k(hp)^.op2t,@pai68k(hp)^.reglist)
+                              else
+                               s:=s+','+getopstr(pai68k(hp)^.op2t,pai68k(hp)^.op2);
+                            { three operands }
+                              if pai68k(hp)^.op3t<>top_none then
+                               begin
+                                   if (pai68k(hp)^._operator = A_DIVSL) or
+                                      (pai68k(hp)^._operator = A_DIVUL) or
+                                      (pai68k(hp)^._operator = A_MULU) or
+                                      (pai68k(hp)^._operator = A_MULS) or
+                                      (pai68k(hp)^._operator = A_DIVS) or
+                                      (pai68k(hp)^._operator = A_DIVU) then
+                                    s:=s+':'+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3)
+                                   else
+                                    s:=s+','+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3);
+                               end;
+                            end;
+                        end;
+                       AsmWriteLn(s);
+                     end;
+{$ifdef GDB}
+         ait_stabs : begin
+                       AsmWrite(#9'.stabs ');
+                       AsmWritePChar(pai_stabs(hp)^.str);
+                       AsmLn;
+                     end;
+         ait_stabn : begin
+                       AsmWrite(#9'.stabn ');
+                       AsmWritePChar(pai_stabn(hp)^.str);
+                       AsmLn;
+                     end;
+ait_stab_function_name : funcname:=pai_stab_function_name(hp)^.str;
+{$endif GDB}
+         else
+          internalerror(10000);
+         end;
+         hp:=pai(hp^.next);
+       end;
+    end;
+
+    procedure tm68kmitasmlist.WriteAsmList;
+{$ifdef GDB}
+    var
+      p,n,e : string;
+{$endif}
+    begin
+{$ifdef EXTDEBUG}
+      if assigned(current_module^.mainsource) then
+       comment(v_info,'Start writing gas-styled assembler output for '+current_module^.mainsource^);
+{$endif}
+      infile:=nil;
+      includecount:=0;
+{$ifdef GDB}
+      if assigned(current_module^.mainsource) then
+       fsplit(current_module^.mainsource^,p,n,e)
+      else
+       begin
+         p:=inputdir;
+         n:=inputfile;
+         e:=inputextension;
+       end;
+    { to get symify to work }
+      AsmWriteLn(#9'.file "'+FixFileName(n+e)+'"');
+    { stabs }
+      n_line:=n_bssline;
+      if (cs_debuginfo in aktswitches) then
+       begin
+         if (p<>'') then
+          AsmWriteLn(#9'.stabs "'+FixPath(p)+'",'+tostr(n_sourcefile)+',0,0,Ltext0');
+         AsmWriteLn(#9'.stabs "'+FixFileName(n+e)+'",'+tostr(n_sourcefile)+',0,0,Ltext0');
+         AsmWriteLn('Ltext0:');
+       end;
+      infile:=current_module^.sourcefiles.files;
+{$endif GDB}
+
+    { main source file is last in list }
+      while assigned(infile^._next) do
+       infile:=infile^._next;
+      lastline:=0;
+      { there should be nothing but externals so we don't need to process
+      WriteTree(externals); }
+      WriteTree(debuglist);
+
+    { code segment }
+      AsmWriteln('.text');
+{$ifdef GDB}
+      n_line:=n_textline;
+{$endif GDB}
+      WriteTree(codesegment);
+
+      AsmWriteLn('.data');
+{$ifdef EXTDEBUG}
+      AsmWriteLn(#9'.ascii'#9'"compiled by FPC '+version_string+'\0"');
+      AsmWriteLn(#9'.ascii'#9'"target: '+target_info.target_name+'\0"');
+{$endif EXTDEBUG}
+{$ifdef GDB}
+      n_line:=n_dataline;
+{$endif GDB}
+      DataSegment^.insert(new(pai_align,init(4)));
+      WriteTree(datasegment);
+      WriteTree(consts);
+
+    { makes problems with old GNU ASes
+      AsmWriteLn('.bss');
+      bssSegment^.insert(new(pai_align,init(4))); }
+{$ifdef GDB}
+      n_line:=n_bssline;
+{$endif GDB}
+      WriteTree(bsssegment);
+
+      AsmLn;
+{$ifdef EXTDEBUG}
+      if assigned(current_module^.mainsource) then
+       comment(v_info,'Done writing gas-styled assembler output for '+current_module^.mainsource^);
+{$endif EXTDEBUG}
+    end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:16  root
+  Initial revision
+
+  Revision 1.3  1998/03/22 12:45:37  florian
+    * changes of Carl-Eric to m68k target commit:
+      - wrong nodes because of the new string cg in intel, I had to create
+        this under m68k also ... had to work it out to fix potential alignment
+        problems --> this removes the crash of the m68k compiler.
+      - added absolute addressing in m68k assembler (required for Amiga startup)
+      - fixed alignment problems (because of byte return values, alignment
+        would not be always valid) -- is this ok if i change the offset if odd in
+        setfirsttemp ?? -- it seems ok...
+
+  Revision 1.2  1998/03/10 04:22:45  carl
+    - removed in because can cause range check errors in BP
+
+  Revision 1.1  1998/03/10 01:26:10  peter
+    + new uniform names
+
+  Revision 1.8  1998/03/09 12:58:11  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.7  1998/03/06 00:52:25  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.6  1998/03/02 01:48:44  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.5  1998/02/23 02:53:52  carl
+    * some bugfix with $extdebug
+
+  Revision 1.4  1998/02/22 23:03:19  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.3  1998/02/22 21:56:29  carl
+    * bugfix of offset with index
+
+  Revision 1.2  1998/02/21 20:20:01  carl
+    * make it work under older versions of GAS
+
+}

compiler/ag68kmot.pas

@@ -0,0 +1,515 @@
+{
+    $Id$
+    Copyright (c) 1998 by the FPC development team
+
+    This unit implements an asmoutput class for MOTOROLA syntax with
+    Motorola 68000 (recognized by the Amiga Assembler and Charlie Gibbs's
+    A68k)
+
+    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 ag68kmot;
+
+    interface
+
+    uses aasm,assemble;
+
+    type
+      pm68kmotasmlist=^tm68kmotasmlist;
+      tm68kmotasmlist = object(tasmlist)
+        procedure WriteTree(p:paasmoutput);virtual;
+        procedure WriteAsmList;virtual;
+      end;
+
+  implementation
+
+    uses
+      dos,globals,systems,cobjects,m68k,
+      strings,files,verbose
+{$ifdef GDB}
+      ,gdb
+{$endif GDB}
+      ;
+
+    const
+      line_length = 70;
+
+    function getreferencestring(const ref : treference) : string;
+      var
+         s : string;
+      begin
+         s:='';
+         if ref.isintvalue then
+             s:='#'+tostr(ref.offset)
+         else
+           with ref do
+             begin
+                 if (index=R_NO) and (base=R_NO) and (direction=dir_none) then
+                   begin
+                     if assigned(symbol) then
+                       begin
+                         s:=s+symbol^;
+                         if offset<0 then
+                           s:=s+tostr(offset)
+                         else
+                         if (offset>0) then
+                           s:=s+'+'+tostr(offset);
+                       end
+                     else
+                       begin
+                       { direct memory addressing }
+                         s:=s+'('+tostr(offset)+').l';
+                       end;
+                   end
+                 else
+                   begin
+                     if assigned(symbol) then
+                       s:=s+symbol^;
+                     if offset<0 then
+                       s:=s+tostr(offset)
+                     else
+                     if (offset>0) then
+                       begin
+                         if (symbol=nil) then s:=tostr(offset)
+                         else s:=s+'+'+tostr(offset);
+                       end;
+                     if (index<>R_NO) and (base=R_NO) and (direction=dir_none) then
+                       begin
+                         if (scalefactor = 1) or (scalefactor = 0) then
+                           begin
+                             if offset = 0 then
+                               s:=s+'0(,'+mot_reg2str[index]+'.l)'
+                             else
+                               s:=s+'(,'+mot_reg2str[index]+'.l)';
+                           end
+                         else
+                           begin
+                             if offset = 0 then
+                               s:=s+'0(,'+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')'
+                             else
+                               s:=s+'(,'+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')';
+                           end
+                       end
+                     else
+                     if (index=R_NO) and (base<>R_NO) and (direction=dir_inc) then
+                       begin
+                         if (scalefactor = 1) or (scalefactor = 0) then
+                           s:=s+'('+mot_reg2str[base]+')+'
+                         else
+                           InternalError(10002);
+                       end
+                     else
+                     if (index=R_NO) and (base<>R_NO) and (direction=dir_dec) then
+                       begin
+                         if (scalefactor = 1) or (scalefactor = 0) then
+                           s:=s+'-('+mot_reg2str[base]+')'
+                         else
+                           InternalError(10003);
+                       end
+                     else
+                     if (index=R_NO) and (base<>R_NO) and (direction=dir_none) then
+                       begin
+                         s:=s+'('+mot_reg2str[base]+')';
+                       end
+                     else
+                     if (index<>R_NO) and (base<>R_NO) and (direction=dir_none) then
+                       begin
+                         if (scalefactor = 1) or (scalefactor = 0) then
+                           begin
+                             if offset = 0 then
+                               s:=s+'0('+mot_reg2str[base]+','+mot_reg2str[index]+'.l)'
+                             else
+                               s:=s+'('+mot_reg2str[base]+','+mot_reg2str[index]+'.l)';
+                           end
+                         else
+                          begin
+                            if offset = 0 then
+                              s:=s+'0('+mot_reg2str[base]+','+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')'
+                            else
+                              s:=s+'('+mot_reg2str[base]+','+mot_reg2str[index]+'.l*'+tostr(scalefactor)+')';
+                          end
+                       end
+      { if this is not a symbol, and is not in the above, then there is an error }
+                     else
+                     if NOT assigned(symbol) then
+                       InternalError(10004);
+                   end; { endif }
+            end; { end with }
+         getreferencestring:=s;
+      end;
+
+
+    function getopstr(t : byte;o : pointer) : string;
+     var
+      hs : string;
+      i: tregister;
+    begin
+      case t of
+       top_reg : getopstr:=mot_reg2str[tregister(o)];
+         top_reglist: begin
+                      hs:='';
+                      for i:=R_NO to R_FPSR do
+                      begin
+                        if i in tregisterlist(o^) then
+                         hs:=hs+mot_reg2str[i]+'/';
+                      end;
+                      delete(hs,length(hs),1);
+                      getopstr := hs;
+                    end;
+       top_ref : getopstr:=getreferencestring(preference(o)^);
+       top_const : getopstr:='#'+tostr(longint(o));
+       top_symbol : begin
+             { compare with i386 version, where this is a constant. }
+             hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
+                     move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
+{                     inc(byte(hs[0]));}
+{                     hs[1]:='#';}
+                     if pcsymbol(o)^.offset>0 then
+                       hs:=hs+'+'+tostr(pcsymbol(o)^.offset)
+                     else if pcsymbol(o)^.offset<0 then
+                       hs:=hs+tostr(pcsymbol(o)^.offset);
+                     getopstr:=hs;
+                   end;
+         else internalerror(10001);
+       end;
+     end;
+
+
+   function getopstr_jmp(t : byte;o : pointer) : string;
+     var
+       hs : string;
+     begin
+       case t of
+         top_reg : getopstr_jmp:=mot_reg2str[tregister(o)];
+         top_ref : getopstr_jmp:=getreferencestring(preference(o)^);
+         top_const : getopstr_jmp:=tostr(longint(o));
+         top_symbol : begin
+                     hs[0]:=chr(strlen(pchar(pcsymbol(o)^.symbol)));
+                     move(pchar(pcsymbol(o)^.symbol)^,hs[1],byte(hs[0]));
+                     if pcsymbol(o)^.offset>0 then
+                       hs:=hs+'+'+tostr(pcsymbol(o)^.offset)
+                     else if pcsymbol(o)^.offset<0 then
+                       hs:=hs+tostr(pcsymbol(o)^.offset);
+                     getopstr_jmp:=hs;
+                   end;
+         else internalerror(10001);
+       end;
+     end;
+
+{****************************************************************************
+                              TM68KMOTASMLIST
+ ****************************************************************************}
+
+    procedure tm68kmotasmlist.WriteTree(p:paasmoutput);
+    var
+      hp        : pai;
+      s         : string;
+      counter,
+      i,j,lines : longint;
+      quoted    : boolean;
+    begin
+      hp:=pai(p^.first);
+      while assigned(hp) do
+       begin
+         case hp^.typ of
+       ait_comment : ;
+         ait_align : AsmWriteLn(#9'CNOP 0,'+tostr(pai_align(hp)^.aligntype));
+      ait_external : AsmWriteLn(#9'XREF'#9+StrPas(pai_external(hp)^.name));
+ ait_real_extended : Message(assem_e_extended_not_supported);
+          ait_comp : Message(assem_e_comp_not_supported);
+     ait_datablock : begin
+                       { ------------------------------------------------------- }
+                       { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- }
+                       { ------------- REQUIREMENT FOR 680x0 ------------------- }
+                       { ------------------------------------------------------- }
+                       if pai_datablock(hp)^.size <> 1 then
+                        begin
+                          if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9'CNOP 0,4')
+                          else
+                           AsmWriteLn(#9'CNOP 0,2');
+                         end;
+                       if pai_datablock(hp)^.is_global then
+                        AsmWriteLn(#9'XDEF'#9+StrPas(pai_datablock(hp)^.name));
+                       AsmWriteLn(StrPas(pai_datablock(hp)^.name)+#9#9'DS.B '+tostr(pai_datablock(hp)^.size));
+                     end;
+   ait_const_32bit : Begin
+                        if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9'CNOP 0,4')
+                        else
+                           AsmWriteLn(#9'CNOP 0,2');
+                       AsmWriteLn(#9#9'DC.L'#9+tostr(pai_const(hp)^.value));
+                     end;
+   ait_const_16bit : Begin
+                        if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9'CNOP 0,4')
+                        else
+                           AsmWriteLn(#9'CNOP 0,2');
+                       AsmWriteLn(#9#9'DC.W'#9+tostr(pai_const(hp)^.value));
+                     end;
+    ait_const_8bit : AsmWriteLn(#9#9'DC.B'#9+tostr(pai_const(hp)^.value));
+  ait_const_symbol : Begin
+                        if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9'CNOP 0,4')
+                        else
+                           AsmWriteLn(#9'CNOP 0,2');
+                       AsmWriteLn(#9#9+'DC.L '#9+StrPas(pchar(pai_const(hp)^.value)));
+                     end;
+    ait_real_64bit : Begin
+                        if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9'CNOP 0,4')
+                        else
+                           AsmWriteLn(#9'CNOP 0,2');
+                       AsmWriteLn(#9#9'DC.D'#9+double2str(pai_double(hp)^.value));
+                     end;
+    ait_real_32bit : Begin
+                        if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9'CNOP 0,4')
+                        else
+                           AsmWriteLn(#9'CNOP 0,2');
+                       AsmWriteLn(#9#9'DC.S'#9+double2str(pai_single(hp)^.value));
+                     end;
+{ TO SUPPORT SOONER OR LATER!!!
+    ait_comp       : AsmWriteLn(#9#9'DC.D'#9+comp2str(pai_extended(hp)^.value));}
+        ait_string : begin
+                       counter := 0;
+                       lines := pai_string(hp)^.len div line_length;
+                       { separate lines in different parts }
+                       if pai_string(hp)^.len > 0 then
+                       Begin
+                         for j := 0 to lines-1 do
+                           begin
+                              AsmWrite(#9#9'DC.B'#9);
+                              quoted:=false;
+                              for i:=counter to counter+line_length do
+                                 begin
+                                   { it is an ascii character. }
+                                   if (ord(pai_string(hp)^.str[i])>31) and
+                                      (ord(pai_string(hp)^.str[i])<128) and
+                                      (pai_string(hp)^.str[i]<>'"') then
+                                   begin
+                                     if not(quoted) then
+                                     begin
+                                       if i>counter then
+                                         AsmWrite(',');
+                                       AsmWrite('"');
+                                     end;
+                                     AsmWrite(pai_string(hp)^.str[i]);
+                                     quoted:=true;
+                                   end { if > 31 and < 128 and ord('"') }
+                                   else
+                                   begin
+                                     if quoted then
+                                       AsmWrite('"');
+                                     if i>counter then
+                                       AsmWrite(',');
+                                     quoted:=false;
+                                     AsmWrite(tostr(ord(pai_string(hp)^.str[i])));
+                                   end;
+                                end; { end for i:=0 to... }
+                                if quoted then AsmWrite('"');
+                                AsmWrite(target_info.newline);
+                                counter := counter+line_length;
+                               end; { end for j:=0 ... }
+                               { do last line of lines }
+                               AsmWrite(#9#9'DC.B'#9);
+                               quoted:=false;
+                               for i:=counter to pai_string(hp)^.len-1 do
+                               begin
+                                 { it is an ascii character. }
+                                 if (ord(pai_string(hp)^.str[i])>31) and
+                                    (ord(pai_string(hp)^.str[i])<128) and
+                                    (pai_string(hp)^.str[i]<>'"') then
+                                 begin
+                                   if not(quoted) then
+                                   begin
+                                     if i>counter then
+                                       AsmWrite(',');
+                                     AsmWrite('"');
+                                   end;
+                                 AsmWrite(pai_string(hp)^.str[i]);
+                                   quoted:=true;
+                                 end { if > 31 and < 128 and " }
+                                 else
+                                 begin
+                                   if quoted then
+                                     AsmWrite('"');
+                                     if i>counter then
+                                       AsmWrite(',');
+                                     quoted:=false;
+                                     AsmWrite(tostr(ord(pai_string(hp)^.str[i])));
+                                 end;
+                               end; { end for i:=0 to... }
+                             if quoted then AsmWrite('"');
+                          end; { endif }
+                        AsmLn;
+                      end;
+          ait_label : begin
+                        AsmWrite(lab2str(pai_label(hp)^.l));
+                        if assigned(hp^.next) and not(pai(hp^.next)^.typ in
+                           [ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_const_symbol,
+                            ait_real_64bit,ait_string]) then
+                         AsmWriteLn(':');
+                      end;
+         ait_direct : begin
+                        AsmWritePChar(pai_direct(hp)^.str);
+                        AsmLn;
+                      end;
+ait_labeled_instruction :
+                      Begin
+                      { labeled operand }
+                        if pai_labeled(hp)^._op1 = R_NO then
+                         AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+lab2str(pai_labeled(hp)^.lab))
+                        else
+                      { labeled operand with register }
+                         AsmWriteLn(#9+mot_op2str[pai_labeled(hp)^._operator]+#9+
+                                    reg2str(pai_labeled(hp)^._op1)+','+lab2str(pai_labeled(hp)^.lab))
+                     end;
+        ait_symbol : begin
+                       { ------------------------------------------------------- }
+                       { ----------- ALIGNMENT FOR ANY NON-BYTE VALUE ---------- }
+                       { ------------- REQUIREMENT FOR 680x0 ------------------- }
+                       { ------------------------------------------------------- }
+                       if assigned(hp^.next) and (pai(hp^.next)^.typ in
+                          [ait_const_32bit,ait_const_16bit,ait_const_symbol,
+                           ait_real_64bit,ait_real_32bit,ait_string]) then
+                        begin
+                          if not(cs_littlesize in aktswitches) then
+                           AsmWriteLn(#9'CNOP 0,4')
+                          else
+                           AsmWriteLn(#9'CNOP 0,2');
+                        end;
+                       if pai_symbol(hp)^.is_global then
+                        AsmWriteLn(#9'XDEF '+StrPas(pai_symbol(hp)^.name));
+                       AsmWritePChar(pai_symbol(hp)^.name);
+                       if assigned(hp^.next) and not(pai(hp^.next)^.typ in
+                          [ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_const_symbol,
+                           ait_real_64bit,ait_string,ait_real_32bit]) then
+                        AsmWriteLn(':');
+                     end;
+   ait_instruction : begin
+                       s:=#9+mot_op2str[pai68k(hp)^._operator]+mot_opsize2str[pai68k(hp)^.size];
+                       if pai68k(hp)^.op1t<>top_none then
+                        begin
+                        { call and jmp need an extra handling                          }
+                        { this code is only called if jmp isn't a labeled instruction }
+                          if pai68k(hp)^._operator in [A_JSR,A_JMP] then
+                           s:=s+#9+getopstr_jmp(pai68k(hp)^.op1t,pai68k(hp)^.op1)
+                          else
+                           begin
+                             if pai68k(hp)^.op1t = top_reglist then
+                              s:=s+#9+getopstr(pai68k(hp)^.op1t,@(pai68k(hp)^.reglist))
+                             else
+                              s:=s+#9+getopstr(pai68k(hp)^.op1t,pai68k(hp)^.op1);
+                             if pai68k(hp)^.op2t<>top_none then
+                              begin
+                                if pai68k(hp)^.op2t = top_reglist then
+                                 s:=s+','+getopstr(pai68k(hp)^.op2t,@pai68k(hp)^.reglist)
+                                else
+                                 s:=s+','+getopstr(pai68k(hp)^.op2t,pai68k(hp)^.op2);
+                             { three operands }
+                                if pai68k(hp)^.op3t<>top_none then
+                                 begin
+                                   if (pai68k(hp)^._operator = A_DIVSL) or
+                                      (pai68k(hp)^._operator = A_DIVUL) or
+                                      (pai68k(hp)^._operator = A_MULU) or
+                                      (pai68k(hp)^._operator = A_MULS) or
+                                      (pai68k(hp)^._operator = A_DIVS) or
+                                      (pai68k(hp)^._operator = A_DIVU) then
+                                    s:=s+':'+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3)
+                                   else
+                                    s:=s+','+getopstr(pai68k(hp)^.op3t,pai68k(hp)^.op3);
+                                 end;
+                              end;
+                           end;
+                        end;
+                       AsmWriteLn(s);
+                     end;
+{$ifdef GDB}
+              ait_stabn,
+              ait_stabs,
+ ait_stab_function_name : ;
+{$endif GDB}
+         else
+          internalerror(10000);
+         end;
+{         if ((hp^.typ<>ait_label) and (hp^.typ<>ait_symbol)) or (assigned(hp^.next) and not(pai(hp^.next)^.typ in
+      [ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_const_symbol,
+       ait_real_64bit,ait_string])) then
+         AsmLn}
+         hp:=pai(hp^.next);
+       end;
+    end;
+
+    procedure tm68kmotasmlist.WriteAsmList;
+    begin
+{$ifdef EXTDEBUG}
+      if assigned(current_module^.mainsource) then
+       comment(v_info,'Start writing motorola-styled assembler output for '+current_module^.mainsource^);
+{$endif}
+      WriteTree(externals);
+
+      AsmLn;
+      AsmWriteLn(#9'SECTION _CODE,CODE');
+      WriteTree(codesegment);
+
+      AsmLn;
+      AsmWriteLn(#9'SECTION _DATA,DATA');
+    { write a signature to the file }
+      AsmWriteLn(#9'CNOP 0,4');
+{$ifdef EXTDEBUG}
+      AsmWriteLn(#9'DC.B'#9'"compiled by FPC '+version_string+'\0"');
+      AsmWriteLn(#9'DC.B'#9'"target: '+target_info.target_name+'\0"');
+{$endif EXTDEBUG}
+      WriteTree(datasegment);
+      WriteTree(consts);
+
+      AsmLn;
+      AsmWriteLn(#9'SECTION _BSS,BSS');
+      WriteTree(bsssegment);
+
+      AsmLn;
+      AsmWriteLn(#9'END');
+{$ifdef EXTDEBUG}
+      if assigned(current_module^.mainsource) then
+       comment(v_info,'Done writing motorola-styled assembler output for '+current_module^.mainsource^);
+{$endif}
+    end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:16  root
+  Initial revision
+
+  Revision 1.3  1998/03/22 12:45:37  florian
+    * changes of Carl-Eric to m68k target commit:
+      - wrong nodes because of the new string cg in intel, I had to create
+        this under m68k also ... had to work it out to fix potential alignment
+        problems --> this removes the crash of the m68k compiler.
+      - added absolute addressing in m68k assembler (required for Amiga startup)
+      - fixed alignment problems (because of byte return values, alignment
+        would not be always valid) -- is this ok if i change the offset if odd in
+        setfirsttemp ?? -- it seems ok...
+
+  Revision 1.2  1998/03/10 04:23:33  carl
+    - removed in because can cause range check errors under BP
+
+  Revision 1.1  1998/03/10 01:26:10  peter
+    + new uniform names
+
+}

compiler/aopt386.inc

@@ -0,0 +1,1314 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl and Jonas Maebe
+
+    This include file contains the reloading optimizer for i386+
+
+    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.
+
+ ****************************************************************************
+}
+
+
+{$Define OptimizeMovs}
+
+Type    TwoWords = Record
+            Word1, Word2: Word
+        End;
+Function Reg32(Reg: TRegister): TRegister;
+{Returns the 32 bit component of Reg if it exists, otherwise Reg is returned}
+Begin
+  Reg32 := Reg;
+  If (Reg >= R_AX)
+    Then
+      If (Reg <= R_DI)
+        Then Reg32 := Reg16ToReg32(Reg)
+        Else
+          If (Reg <= R_BL)
+            Then Reg32 := Reg8toReg32(Reg);
+End;
+
+Function RegInRef(Reg: TRegister; Const Ref: TReference): Boolean;
+Begin {checks whether Ref contains a reference to Reg}
+  Reg := Reg32(Reg);
+  RegInRef := (Ref.Base = Reg) Or (Ref.Index = Reg)
+End;
+
+Function RegInInstruction(Reg: TRegister; p1: Pai): Boolean;
+{checks if Reg is used by the instruction p1}
+Var TmpResult: Boolean;
+Begin
+  TmpResult := False;
+  If (Pai(p1)^.typ = ait_instruction) Then
+    Begin
+      Case Pai386(p1)^.op1t Of
+        Top_Reg: TmpResult := Reg = TRegister(Pai386(p1)^.op1);
+        Top_Ref: TmpResult := RegInRef(Reg, TReference(Pai386(p1)^.op1^))
+      End;
+      If Not(TmpResult) Then
+        Case Pai386(p1)^.op2t Of
+          Top_Reg:
+              if Pai386(p1)^.op3t<>Top_reg
+                then TmpResult := Reg = TRegister(Pai386(p1)^.op2)
+                else TmpResult := longint(Reg) = twowords(Pai386(p1)^.op2).word1;
+          Top_Ref: TmpResult := RegInRef(Reg, TReference(Pai386(p1)^.op2^))
+        End;
+      If Not(TmpResult) Then
+        Case Pai386(p1)^.op3t Of
+          Top_Reg: TmpResult := longint(Reg) =twowords(Pai386(p1)^.op2).word2;
+          Top_none:;
+          else
+             internalerror($Da);
+       End
+    End;
+  RegInInstruction := TmpResult
+End;
+
+Procedure ReloadOpt(AsmL: PaasmOutput);
+
+Const MaxCh = 3;
+
+      {content types}
+      con_Unknown = 0;
+      con_ref = 1;
+      con_const = 2;
+      con_symbol = 3;
+
+Type TChange = (C_None,
+                C_EAX, C_ECX, C_EDX, C_EBX, C_ESP, C_EBP, C_ESI, C_EDI,
+{                C_AX,  C_CX,  C_DX,  C_BX,  C_SP,  C_BP,  C_SI,  C_DI,
+                C_AL,  C_CL,  C_DL,  C_BL,
+                C_AH,  C_CH,  C_BH,  C_DH,
+                C_DEFAULT_SEG, C_CS, C_DS, C_ES, C_FS, C_GS, C_SS,
+}                C_Flags, C_FPU,
+                C_Op1, C_Op2, C_Op3,
+                C_MemEDI);
+
+     TAsmInstrucProp = Record
+                         NCh: Byte;
+                         Ch: Array[1..MaxCh] of TChange;
+                       End;
+
+     TContent = Record
+                  StartMod: Pointer; {start and end of block instructions that defines the
+                                          content of this register; If Typ = con_const, then
+                                          Longint(StartMod) = value of the constant)}
+                   State: Word; {starts at 0, gets increased everytime the register is modified}
+                   NrOfMods: Byte;
+{                  ModReg: TRegister; }{if one register gets a block assigned from an other register,
+                                      this variable holds the name of that register (so it can be
+                                      substituted when checking the block afterwards)}
+                  Typ: Byte;        {con_*}
+{                  CanBeDestroyed: Boolean;} {if it's a register modified by the optimizer}
+                End;
+
+     TRegContent = Array[R_NO..R_EDI] Of TContent;
+     TRegFPUContent = Array[R_ST..R_ST7] Of TContent;
+
+     TPaiProp = Record
+                  Regs: TRegContent;
+{                  FPURegs: TRegFPUContent;} {currently not yet used}
+                  LineSave: Longint;
+                  {can this instruction be removed?}
+                  CanBeRemoved: Boolean;
+                End;
+
+     PPaiProp = ^TPaiProp;
+{$IfDef TP}
+     TPaiPropBlock = Array[1..(65520 div (((SizeOf(TPaiProp)+1)div 2)*2))] Of TPaiProp;
+{$else}
+     TPaiPropBlock = Array[1..250000] Of TPaiProp;
+{$EndIf TP}
+     PPaiPropBlock = ^TPaiPropBlock;
+
+Const AsmInstr: Array[tasmop] Of TAsmInstrucProp = (
+   {MOV} (NCh: 1; Ch: (C_Op2, C_None, C_None)),
+ {MOVZX} (NCh: 1; Ch: (C_Op2, C_None, C_None)),
+ {MOVSX} (NCh: 1; Ch: (C_Op2, C_None, C_None)),
+ {LABEL} (NCh: 255; Ch: (C_None, C_None, C_None)), {don't know value of any register}
+   {ADD} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+  {CALL} (NCh: 255; Ch: (C_None, C_None, C_None)), {don't know value of any register}
+  {IDIV} (NCh: 3; Ch: (C_EAX, C_EDX, C_Flags)),
+  {IMUL} (NCh: 3; Ch: (C_EAX, C_EDX, C_Flags)), {handled separately, because several forms exist}
+   {JMP} (NCh: 255; Ch: (C_None, C_None, C_None)), {don't know value of any register}
+   {LEA} (NCh: 1; Ch: (C_Op2, C_None, C_None)),
+   {MUL} (NCh: 3; Ch: (C_EAX, C_EDX, C_Flags)),
+   {NEG} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+   {NOT} (NCh: 2; Ch: (C_Op1, C_Flags, C_None)),
+   {POP} (NCh: 2; Ch: (C_Op1, C_ESP, C_None)),
+ {POPAD} (NCh: 255; Ch: (C_None, C_None, C_None)), {don't know value of any register}
+  {PUSH} (NCh: 1; Ch: (C_ESP, C_None, C_None)),
+{PUSHAD} (NCh: 1; Ch: (C_ESP, C_None, C_None)),
+   {RET} (NCh: 255; Ch: (C_None, C_None, C_None)), {don't know value of any register}
+   {SUB} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+  {XCHG} (NCh: 2; Ch: (C_Op1, C_Op2, C_None)), {(will be) handled seperately}
+   {XOR} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+  {FILD} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+   {CMP} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+    {JZ} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {INC} (NCh: 2; Ch: (C_Op1, C_Flags, C_None)),
+   {DEC} (NCh: 2; Ch: (C_Op1, C_Flags, C_None)),
+  {SETE} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETNE} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {SETL} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {SETG} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETLE} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETGE} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+    {JE} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JNE} (NCh: 0; Ch: (C_None, C_None, C_None)),
+    {JL} (NCh: 0; Ch: (C_None, C_None, C_None)),
+    {JG} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JLE} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JGE} (NCh: 0; Ch: (C_None, C_None, C_None)),
+    {OR} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {FLD} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FADD} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FMUL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FSUB} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FDIV} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FCHS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FLD1} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FIDIV} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {CLTD} (NCh: 1; Ch: (C_EDX, C_None, C_None)),
+   {JNZ} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {FSTP} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+   {AND} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {JNO} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {NOTH} (NCh: 0; Ch: (C_None, C_None, C_None)), {***???***}
+  {NONE} (NCh: 0; Ch: (C_None, C_None, C_None)),
+ {ENTER} (NCh: 1; Ch: (C_ESP, C_None, C_None)),
+ {LEAVE} (NCh: 1; Ch: (C_ESP, C_None, C_None)),
+   {CLD} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+  {MOVS} (NCh: 3; Ch: (C_ESI, C_EDI, C_MemEDI)),
+   {REP} (NCh: 1; Ch: (C_ECX, C_None, C_None)),
+   {SHL} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {SHR} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+ {BOUND} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JNS} (NCh: 0; Ch: (C_None, C_None, C_None)),
+    {JS} (NCh: 0; Ch: (C_None, C_None, C_None)),
+    {JO} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {SAR} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+  {TEST} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+  {FCOM} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FCOMP} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FCOMPP} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FXCH} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FADDP} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FMULP} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FSUBP} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FDIVP} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FNSTS} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {SAHF} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+{FDIVRP} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FSUBRP} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {SETC} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETNC} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+    {JC} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JNC} (NCh: 0; Ch: (C_None, C_None, C_None)),
+    {JA} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JAE} (NCh: 0; Ch: (C_None, C_None, C_None)),
+    {JB} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JBE} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {SETA} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETAE} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {SETB} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETBE} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+   {AAA} (NCh: 2; Ch: (C_EAX, C_Flags, C_None)),
+   {AAD} (NCh: 2; Ch: (C_EAX, C_Flags, C_None)),
+   {AAM} (NCh: 2; Ch: (C_EAX, C_Flags, C_None)),
+   {AAS} (NCh: 2; Ch: (C_EAX, C_Flags, C_None)),
+   {CBW} (NCh: 1; Ch: (C_EAX, C_None, C_None)),
+   {CDQ} (NCh: 2; Ch: (C_EAX, C_EDX, C_None)),
+   {CLC} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+   {CLI} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+  {CLTS} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {CMC} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+   {CWD} (NCh: 2; Ch: (C_EAX, C_EDX, C_None)),
+  {CWDE} (NCh: 1; Ch: (C_EAX, C_None, C_None)),
+   {DAA} (NCh: 1; Ch: (C_EAX, C_None, C_None)),
+   {DAS} (NCh: 1; Ch: (C_EAX, C_None, C_None)),
+   {HLT} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {IRET} (NCh: 255; Ch: (C_None, C_None, C_None)), {don't know value of any register}
+  {LAHF} (NCh: 1; Ch: (C_EAX, C_None, C_None)),
+  {LODS} (NCh: 2; Ch: (C_EAX, C_ESI, C_None)),
+  {LOCK} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {NOP} (NCh: 0; Ch: (C_None, C_None, C_None)),
+ {PUSHA} (NCh: 1; Ch: (C_ESP, C_None, C_None)),
+ {PUSHF} (NCh: 1; Ch: (C_ESP, C_None, C_None)),
+{PUSHFD} (NCh: 1; Ch: (C_ESP, C_None, C_None)),
+   {STC} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+   {STD} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+   {STI} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+  {STOS} (NCh: 2; Ch: (C_MemEDI, C_EDI, C_None)),
+  {WAIT} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {XLAT} (NCh: 1; Ch: (C_EAX, C_None, C_None)),
+ {XLATB} (NCh: 1; Ch: (C_EAX, C_None, C_None)),
+ {MOVSB} (NCh: 1; Ch: (C_Op2, C_None, C_None)),
+{MOVSBL} (NCh: 1; Ch: (C_Op2, C_None, C_None)),
+{MOVSBW} (NCh: 1; Ch: (C_Op2, C_None, C_None)),
+{MOVSWL} (NCh: 1; Ch: (C_Op2, C_None, C_None)),
+ {MOVZB} (NCh: 1; Ch: (C_Op2, C_None, C_None)),
+{MOVZWL} (NCh: 1; Ch: (C_Op2, C_None, C_None)),
+  {POPA} (NCh: 255; Ch: (C_None, C_None, C_None)), {don't know value of any register}
+    {IN} (NCh: 1; Ch: (C_Op2, C_None, C_None)),
+   {OUT} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {LDS} (NCh: 2; Ch: (C_Op2, C_None, C_None)),
+   {LCS} (NCh: 2; Ch: (C_Op2, C_None, C_None)),
+   {LES} (NCh: 2; Ch: (C_Op2, C_None, C_None)),
+   {LFS} (NCh: 2; Ch: (C_Op2, C_None, C_None)),
+   {LGS} (NCh: 2; Ch: (C_Op2, C_None, C_None)),
+   {LSS} (NCh: 2; Ch: (C_Op2, C_None, C_None)),
+  {POPF} (NCh: 2; Ch: (C_Flags, C_ESP, C_None)),
+   {SBB} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {ADC} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {DIV} (NCh: 3; Ch: (C_EAX, C_EDX, C_Flags)),
+   {ROR} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {ROL} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {RCL} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {RCR} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {SAL} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+  {SHLD} (NCh: 2; Ch: (C_Op3, C_Flags, C_None)),
+  {SHRD} (NCh: 2; Ch: (C_Op3, C_Flags, C_None)),
+ {LCALL} (NCh: 255; Ch: (C_None, C_None, C_None)), {don't know value of any register}
+  {LJMP} (NCh: 255; Ch: (C_None, C_None, C_None)), {don't know value of any register}
+  {LRET} (NCh: 255; Ch: (C_None, C_None, C_None)), {don't know value of any register}
+  {JNAE} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JNB} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JNA} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {JNBE} (NCh: 0; Ch: (C_None, C_None, C_None)),
+    {JP} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JNP} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JPE} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JPO} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {JNGE} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JNG} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {JNL} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {JNLE} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {JCXZ} (NCh: 0; Ch: (C_None, C_None, C_None)),
+ {JECXZ} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {LOOP} (NCh: 1; Ch: (C_ECX, C_None, C_None)),
+  {CMPS} (NCh: 3; Ch: (C_ESI, C_EDI, C_Flags)),
+   {INS} (NCh: 1; Ch: (C_EDI, C_None, C_None)),
+  {OUTS} (NCh: 1; Ch: (C_ESI, C_None, C_None)),
+  {SCAS} (NCh: 2; Ch: (C_EDI, C_Flags, C_None)),
+   {BSF} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {BSR} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+    {BT} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+   {BTC} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {BTR} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {BTS} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {INT} (NCh: 255; Ch: (C_None, C_None, C_None)), {don't know value of any register}
+  {INT3} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {INTO} (NCh: 255; Ch: (C_None, C_None, C_None)), {don't know value of any register}
+{BOUNDL} (NCh: 0; Ch: (C_None, C_None, C_None)),
+{BOUNDW} (NCh: 0; Ch: (C_None, C_None, C_None)),
+ {LOOPZ} (NCh: 1; Ch: (C_ECX, C_None, C_None)),
+ {LOOPE} (NCh: 1; Ch: (C_ECX, C_None, C_None)),
+{LOOPNZ} (NCh: 1; Ch: (C_ECX, C_None, C_None)),
+{LOOPNE} (NCh: 1; Ch: (C_ECX, C_None, C_None)),
+  {SETO} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETNO} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{SETNAE} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETNB} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {SETZ} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETNZ} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETNA} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{SETNBE} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {SETS} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETNS} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {SETP} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETPE} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETNP} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETPO} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{SETNGE} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETNL} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {SETNG} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{SETNLE} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {ARPL} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+   {LAR} (NCh: 1; Ch: (C_Op2, C_None, C_None)),
+  {LGDT} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {LIDT} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {LLDT} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {LMSW} (NCh: 0; Ch: (C_None, C_None, C_None)),
+   {LSL} (NCh: 2; Ch: (C_Op2, C_Flags, C_None)),
+   {LTR} (NCh: 0; Ch: (C_None, C_None, C_None)),
+  {SGDT} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {SIDT} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {SLDT} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {SMSW} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {STR}  (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {VERR} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+  {VERW} (NCh: 1; Ch: (C_Flags, C_None, C_None)),
+  {FABS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FBLD} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FBSTP} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {FCLEX} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FNCLEX} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FCOS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FDECSTP}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FDISI} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FNDISI} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FDIVR} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FENI} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FNENI} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FFREE} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FIADD} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FICOM} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FICOMP} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FIDIVR} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FIMUL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FINCSTP}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FINIT} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FNINIT} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FIST} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {FISTP} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {FISUB} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FSUBR} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FLDCW} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FLDENV} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FLDLG2} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FLDLN2} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FLDL2E} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FLDL2T} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FLDPI} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FLDS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FLDZ} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FNOP} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FPATAN} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FPREM} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FPREM1} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FPTAN} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FRNDINT}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FRSTOR} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FSAVE} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{FNSAVE} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FSCALE} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FSETPM} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FSIN} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FSINCOS}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FSQRT} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+   {FST} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {FSTCW} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{FNSTCW} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{FSTENV} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{FNSTENV}(NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {FSTSW} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{FNSTSW} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {FTST} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FUCOM} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FUCOMP} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FUCOMPP}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FWAIT} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FXAM} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FXTRACT}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FYL2X} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FYL2XP1}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {F2XM1} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FILDQ} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FILDS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FILDL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FLDL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {FLDT} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FISTQ} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {FISTS} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {FISTL} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {FSTL} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+  {FSTS} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {FSTPS} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{FISTPL} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {FSTPL} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{FISTPS} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{FISTPQ} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+ {FSTPT} (NCh: 1; Ch: (C_Op1, C_None, C_None)),
+{FCOMPS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FICOMPL}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FCOMPL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FICOMPS}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FCOMS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FICOML} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FCOML} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FICOMS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FIADDL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FADDL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FIADDS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FISUBL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FSUBL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FISUBS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FSUBS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FSUBR} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FSUBRS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FISUBRL}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FSUBRL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FISUBRS}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FMULS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FIMUL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FMULL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FIMULS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FIDIVS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FIDIVL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {FDIVL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FIDIVS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FDIVRS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FIDIVRL}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FDIVRL} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{FIDIVRS}(NCh: 1; Ch: (C_FPU, C_None, C_None)),
+  {REPE} (NCh: 0; Ch: (C_ECX, C_None, C_None)),
+ {REPNE} (NCh: 0; Ch: (C_ECX, C_None, C_None)),
+ {FADDS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+ {POPFD} (NCh: 2; Ch: (C_ESP, C_Flags, C_None)),
+{below are the MMX instructions}
+{A_EMMS} (NCh: 1; Ch: (C_FPU, C_None, C_None)),
+{A_MOVD} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_MOVQ} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PACKSSDW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PACKSSWB} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PACKUSWB} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PADDB} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PADDD} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PADDSB} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PADDSW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PADDUSB} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PADDUSW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PADDW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PAND} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PANDN} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PCMPEQB} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PCMPEQD} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PCMPEQW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PCMPGTB} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PCMPGTD} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PCMPGTW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PMADDWD} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PMULHW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PMULLW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_POR} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSLLD} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSLLQ} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSLLW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSRAD} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSRAW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSRLD} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSRLQ} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSRLW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSUBB} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSUBD} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSUBSB} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSUBSW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSUBUSB} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSUBUSW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PSUBW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PUNPCKHBW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PUNPCKHDQ} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PUNPCKHWD} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PUNPCKLBW} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PUNPCKLDQ} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PUNPCKLWD} (NCh: 255; Ch: (C_FPU, C_None, C_None)),
+{A_PXOR} (NCh: 255; Ch: (C_FPU, C_None, C_None)));
+
+Var NrOfPaiObjs, NrOfPaiFast: Longint;
+    PaiPropBlock: PPaiPropBlock;
+    NrOfInstrSinceLastMod: Array[R_EAX..R_EDI] Of Byte;
+
+Function TCh2Reg(Ch: TChange): TRegister;
+{converts a TChange variable to a TRegister}
+Begin
+  If (CH <= C_EDI)
+    Then TCh2Reg := TRegister(Byte(Ch))
+    Else InternalError($db)
+End;
+
+Procedure DestroyReg(p1: pai; Reg: TRegister);
+{Destroys the contents of the register Reg in the PPaiProp of P}
+Var TmpState: Longint;
+Begin
+  Reg := Reg32(Reg);
+  NrOfInstrSinceLastMod[Reg] := 0;
+  If (Reg >= R_EAX) And (Reg <= R_EDI)
+    Then
+      Begin
+        TmpState := PPaiProp(p1^.line)^.Regs[Reg].State+1;
+        FillChar(PPaiProp(p1^.line)^.Regs[Reg], SizeOf(TContent), 0);
+        PPaiProp(p1^.line)^.Regs[Reg].State := TmpState;
+      End;
+End;
+
+(*Function FindZeroreg(p: Pai; Var Result: TRegister): Boolean;
+{Finds a register which contains the constant zero}
+Var Counter: TRegister;
+Begin
+  Counter := R_EAX;
+  FindZeroReg := True;
+  While (Counter <= R_EDI) And
+        ((PPaiProp(p^.line)^.Regs[Counter].Typ <> Con_Const) or
+         (PPaiProp(p^.line)^.Regs[Counter].StartMod <> Pointer(0))) Do
+    Inc(Byte(Counter));
+  If (PPaiProp(p^.line)^.Regs[Counter].Typ = Con_Const) And
+     (PPaiProp(p^.line)^.Regs[Counter].StartMod = Pointer(0))
+    Then Result := Counter
+    Else FindZeroReg := False;
+End;*)
+
+Procedure DestroyRefs(p: pai; Const Ref: TReference; WhichRegNot: TRegister);
+{destroys all registers which possibly contain a reference to Ref}
+Var Counter: TRegister;
+Begin
+WhichRegNot := Reg32(WhichRegNot);
+If (Ref.base <> R_NO) Or
+   (Ref.index <> R_NO)
+  Then
+    Begin
+      If (Ref.base = ProcInfo.FramePointer)
+        Then
+{write something to a parameter or a local variable}
+          For Counter := R_EAX to R_EDI Do
+            With PPaiProp(p^.line)^.Regs[Counter] Do
+              Begin
+                If (Counter <> WhichRegNot) And
+                   (typ = Con_Ref) And
+                   (Pai(StartMod)^.typ = ait_instruction) And
+                   (Pai386(StartMod)^.op1t = top_ref) And
+                   (RefsEqual(TReference(Pai386(StartMod)^.op1^), Ref) Or
+                   (Not(cs_UncertainOpts in AktSwitches) And
+                    (NrOfMods <> 1)))
+                  Then DestroyReg(p, Counter)
+              End
+        Else
+          {writing something to a pointer location}
+          For Counter := R_EAX to R_EDI Do
+            With PPaiProp(p^.line)^.Regs[Counter] Do
+            If (Counter <> WhichRegNot) And
+               (typ = Con_Ref) And
+               (Not(cs_UncertainOpts in AktSwitches) Or
+                (Ref.Base = R_EDI) Or
+                (Not((NrOfMods = 1) And
+                (Pai(StartMod)^.typ = ait_instruction) And
+                (Pai386(StartMod)^.op1t = top_ref) And
+                (PReference(Pai386(StartMod)^.op1)^.base = ProcInfo.FramePointer))))
+              Then
+                DestroyReg(p, Counter) {we don't know what memory location the reference points to,
+                                      so we just destroy every register which contains a memory
+                                      reference}
+    End
+  Else {the ref is a var name or we just have a reference an absolute offset}
+    Begin
+      For Counter := R_EAX to R_EDI Do
+        If (Counter <> WhichRegNot) And
+           (PPaiProp(p^.line)^.Regs[Counter].typ = Con_Ref) And
+           (Not(cs_UncertainOpts in AktSwitches) Or
+            RefsEqual(Ref,
+                     TReference(Pai386(PPaiProp(p^.line)^.Regs[Counter].StartMod)^.op1^))) Then
+          DestroyReg(p, Counter)
+    End;
+End;
+
+{$IfDef OptimizeMovs}
+
+Function OpsEqual(typ: Longint; op1, op2: Pointer): Boolean;
+Begin {checks whether the two ops are equal}
+  Case typ Of
+    Top_Reg, Top_Const: OpsEqual := op1 = op2;
+    Top_Ref: OpsEqual := RefsEqual(TReference(op1^), TReference(op2^));
+    Top_None: OpsEqual := True
+    Else OpsEqual := False
+  End;
+End;
+
+Function RegsSameContent(p1, p2: Pai; Reg: TRegister): Boolean;
+{checks whether Reg has the same content in the PPaiProp of p1 and p2}
+Begin
+  Reg := Reg32(Reg);
+  RegsSameContent :=
+    PPaiProp(p1^.line)^.Regs[Reg].State =
+    PPaiProp(p2^.line)^.Regs[Reg].State;
+End;
+
+Function InstructionsEqual(p1, p2: Pai): Boolean;
+Begin {checks whether two Pai386 instructions are equal}
+  InstructionsEqual :=
+    Assigned(p1) And Assigned(p2) And
+    (Pai(p1)^.typ = ait_instruction) And
+    (Pai(p1)^.typ = ait_instruction) And
+    (Pai386(p1)^._operator = Pai386(p2)^._operator) And
+    (Pai386(p1)^.op1t = Pai386(p2)^.op1t) And
+    (Pai386(p1)^.op2t = Pai386(p2)^.op2t) And
+    OpsEqual(Pai386(p1)^.op1t, Pai386(p1)^.op1, Pai386(p2)^.op1) And
+    OpsEqual(Pai386(p1)^.op2t, Pai386(p1)^.op2, Pai386(p2)^.op2)
+End;
+
+Function CheckSequence(p: Pai; Reg: TRegister; Var Found: Longint): Boolean;
+{checks whether the current instruction sequence (starting with p) and the
+ one between StartMod and EndMod of Reg are the same. If so, the number of
+ instructions that match is stored in Found and true is returned, otherwise
+ Found holds the number of instructions between StartMod and EndMod and false
+ is returned}
+Var hp2, hp3, EndMod: Pai;
+    TmpResult: Boolean;
+    RegsNotYetChecked: Set Of TRegister;
+    Counter: Byte;
+
+Function NoChangedRegInRef(oldp, newp: Pai): Boolean;
+Var TmpP: Pai;
+{checks if the first operator of newp is a reference and in that case checks
+ whether that reference includes regs that have been changed since oldp. This
+ to avoid wrong optimizations like
+
+ movl 8(%epb), %eax                          movl 8(%epb), %eax
+ movl 12(%epb), %edx                         movl 12(%epb), %edx
+ movl (%eax,%edx,1), %edi                    movl (%eax,%edx,1), %edi
+ pushl %edi              being converted to  pushl %edi
+ movl 8(%epb), %eax                          movl 16(%ebp), %edx
+ movl 16(%epb), %edx                         pushl %edi
+ movl (%eax,%edx,1), %edi
+ pushl %edi
+
+because first is checked whether %eax isn't changed (it isn't) and
+consequently all instructions containg %eax are removed}
+Begin
+  TmpResult := True;
+  If (Pai(oldp)^.typ = ait_instruction) Then {oldp and newp are the same instruction}
+    Case Pai386(oldp)^.op1t Of
+      Top_Reg:
+        If (Reg32(TRegister(Pai386(oldp)^.op1)) in RegsNotYetChecked) Then
+          Begin
+            RegsNotYetChecked := RegsNotYetChecked - [Reg32(TRegister(Pai386(oldp)^.op1))];
+            If Assigned(newp^.Last)
+              Then
+                Begin
+                  TmpP := Pai(newp^.last);
+                  While Assigned (TmpP^.Last) And
+                        PPaiProp(TmpP^.Line)^.CanBeRemoved Do
+                    TmpP := Pai(TmpP^.Last);
+                  TmpResult := Assigned(TmpP) And
+                               RegsSameContent(oldp, TmpP, Reg32(TRegister(Pai386(oldp)^.op1)))
+                End
+              Else TmpResult := False;
+          End;
+      Top_Ref:
+        With TReference(Pai386(oldp)^.op1^) Do
+          Begin
+            If (Base in RegsNotYetChecked) And
+               (Base <> R_NO) Then
+              Begin
+                RegsNotYetChecked := RegsNotYetChecked - [Base];
+                If Assigned(newp^.Last)
+                  Then
+                    Begin
+                      TmpP := Pai(newp^.last);
+                      While Assigned (TmpP^.Last) And
+                            PPaiProp(TmpP^.Line)^.CanBeRemoved Do
+                        TmpP := Pai(TmpP^.Last);
+                      TmpResult := Assigned(TmpP) And
+                                   RegsSameContent(oldp, TmpP, Base)
+                    End
+                  Else TmpResult := False;
+              End;
+            If TmpResult And
+               (Index <> R_NO) And
+               (Index in RegsNotYetChecked) Then
+              Begin
+                RegsNotYetChecked := RegsNotYetChecked - [Index];
+                If Assigned(newp^.Last)
+                  Then
+                    Begin
+                      TmpP := Pai(newp^.last);
+                      While Assigned (TmpP^.Last) And
+                            PPaiProp(TmpP^.Line)^.CanBeRemoved Do
+                        TmpP := Pai(TmpP^.Last);
+                      TmpResult := Assigned(TmpP) And
+                                   RegsSameContent(oldp, TmpP, Index)
+                    End
+                  Else TmpResult := False;
+              End;
+          End;
+    End;
+  NoChangedRegInRef := TmpResult;
+End;
+
+Begin {CheckSequence}
+  Reg := Reg32(Reg);
+  Found := 0;
+  hp2 := p;
+  hp3 := PPaiProp(Pai(p^.last)^.line)^.Regs[Reg].StartMod;
+  EndMod := PPaiProp(Pai(p^.last)^.line)^.Regs[Reg].StartMod;
+  RegsNotYetChecked := [R_EAX..R_EDI];
+  For Counter := 2 to PPaiProp(Pai(p^.last)^.line)^.Regs[Reg].NrOfMods Do
+    EndMod := Pai(EndMod^.Next);
+  While (Found <> PPaiProp(Pai(p^.last)^.line)^.Regs[Reg].NrOfMods) And
+         InstructionsEqual(hp2, hp3) And
+         NoChangedRegInRef(EndMod, hp2) Do
+    Begin
+      hp2 := Pai(hp2^.next);
+      hp3 := Pai(hp3^.next);
+      Inc(Found)
+    End;
+  If (Found <> PPaiProp(Pai(p^.last)^.line)^.Regs[Reg].NrOfMods)
+     Then
+       Begin
+         CheckSequence := False;
+         If (found > 0) then
+ {this is correct because we only need to turn off the CanBeRemoved flag
+  when an instruction has already been processed by CheckSequence
+  (otherwise CanBeRemoved can't be true, or can't have to be turned off).
+  If it has already been processed by checkSequence and flagged to be
+  removed, it means that it has been checked against a previous sequence
+  and that it was equal (otherwise CheckSequence would have returned false
+  and the instruction wouldn't have been removed). If this "If found > 0"
+  check is left out, incorrect optimizations are performed.}
+           Found := PPaiProp(Pai(p)^.line)^.Regs[Reg].NrOfMods
+       End
+     Else CheckSequence := True;
+End; {CheckSequence}
+
+{$Endif OptimizeMovs}
+
+Procedure DestroyAllRegs(p: Pai);
+Var Counter: TRegister;
+Begin {initializes/desrtoys all registers}
+  For Counter := R_EAX To R_EDI Do
+    DestroyReg(p, Counter);
+End;
+
+Procedure Destroy(PaiObj: Pai; opt: Longint; Op: Pointer);
+Begin
+  Case opt Of
+    top_reg: DestroyReg(PaiObj, TRegister(Op));
+    top_ref: DestroyRefs(PaiObj, TReference(Op^), R_NO);
+    top_symbol:;
+  End;
+End;
+
+Function CreateRegs(First: Pai): Pai;
+{Starts creating the reg contents for the instructions starting with p.
+Returns the last pai which has been processed}
+Var
+    TmpProp: PPaiProp;
+    Cnt, InstrCnt: Longint;
+    InstrProp: TAsmInstrucProp;
+    p: Pai;
+    TmpRef: TReference;
+    TmpReg: TRegister;
+Begin
+  p := First;
+  InstrCnt := 1;
+  FillChar(NrOfInstrSinceLastMod, SizeOf(NrOfInstrSinceLastMod), 0);
+  While Assigned(p) Do
+    Begin
+      CreateRegs := p;
+      If (InstrCnt <= NrOfPaiFast)
+        Then TmpProp := @PaiPropBlock^[InstrCnt]
+        Else New(TmpProp);
+      If (p <> First)
+        Then TmpProp^ := PPaiProp(Pai(p^.last)^.line)^
+        Else FillChar(TmpProp^, SizeOf(TmpProp^), 0);
+      TmpProp^.LineSave := p^.line;
+      PPaiProp(p^.line) := TmpProp;
+      For TmpReg := R_EAX To R_EDI Do
+        Inc(NrOfInstrSinceLastMod[TmpReg]);
+      Case p^.typ Of
+        ait_label: DestroyAllRegs(p);
+        ait_labeled_instruction, ait_stabs, ait_stabn,
+        ait_stab_function_name:; {nothing changes}
+        ait_instruction:
+          Begin
+            InstrProp := AsmInstr[Pai386(p)^._operator];
+            Case Pai386(p)^._operator Of
+{$IfDef OptimizeMovs}
+              A_MOV, A_MOVZX, A_MOVSX:
+                Begin
+                  Case Pai386(p)^.op1t Of
+                    Top_Reg:
+                      Case Pai386(p)^.op2t Of
+                        Top_Reg:
+                          Begin
+                            DestroyReg(p, TRegister(Pai386(p)^.op2));
+{                            TmpProp^.Regs[TRegister(Pai386(p)^.op2)] :=
+                              TmpProp^.Regs[TRegister(Pai386(p)^.op1)];
+                            If (TmpProp^.Regs[TRegister(Pai386(p)^.op2)].ModReg = R_NO) Then
+                              TmpProp^.Regs[TRegister(Pai386(p)^.op2)].ModReg :=
+                                Tregister(Pai386(p)^.op1);}
+                          End;
+                        Top_Ref: DestroyRefs(p, TReference(Pai386(p)^.op2^), TRegister(Pai386(p)^.op1));
+                      End;
+                    Top_Ref:
+                      Begin {destination is always a register in this case}
+                        TmpReg := Reg32(TRegister(Pai386(p)^.op2));
+                        If (RegInRef(TmpReg, TReference(Pai386(p)^.op1^)))
+                          Then
+                            Begin
+                              With PPaiProp(Pai(p)^.line)^.Regs[TmpReg] Do
+                                Begin
+                                  Inc(State);
+ {also store how many instructions are part of the sequence in the first
+  instructions PPaiProp, so it can be easily accessed from within
+  CheckSequence}
+                                  If (typ <> Con_Ref) Then
+                                    Begin
+                                      typ := Con_Ref;
+                                      StartMod := p;
+                                    End;
+                                  Inc(NrOfMods, NrOfInstrSinceLastMod[TmpReg]);
+                                  PPaiProp(Pai(StartMod)^.line)^.Regs[TmpReg].NrOfMods := NrOfMods;
+                                  NrOfInstrSinceLastMod[TmpReg] := 0;
+                                End;
+                            End
+                          Else
+                            Begin
+                              DestroyReg(p, TmpReg);
+                              With PPaiProp(Pai(p)^.line)^.Regs[TmpReg] Do
+                                Begin
+                                  Typ := Con_Ref;
+                                  StartMod := p;
+                                  NrOfMods := 1;
+                                End;
+                            End;
+                      End;
+                    Top_Const:
+                      Begin
+                        Case Pai386(p)^.op2t Of
+                          Top_Reg:
+                            Begin
+                              TmpReg := Reg32(TRegister(Pai386(p)^.op2));
+                              With TmpProp^.Regs[TmpReg] Do
+                                Begin
+                                {it doesn't matter that the state is changed,
+                                 it isn't looked at when removing constant reloads}
+                                  DestroyReg(p, TmpReg);
+                                  typ := Con_Const;
+                                  StartMod := Pai386(p)^.op1;
+                                End
+                            End;
+                          Top_Ref: DestroyRefs(P, TReference(Pai386(p)^.op2^), R_NO);
+                        End;
+                      End;
+                End;
+              End;
+{$EndIf OptimizeMovs}
+              A_IMUL:
+                Begin
+                  If (Pai386(p)^.Op3t = top_none)
+                   Then
+                     If (Pai386(p)^.Op2t = top_none)
+                       Then
+                         Begin
+                           DestroyReg(p, R_EAX);
+                           DestroyReg(p, R_EDX)
+                         End
+                       Else
+                         Begin
+                           If (Pai386(p)^.Op2t = top_reg) Then
+                             DestroyReg(p, TRegister(Pai386(p)^.Op2));
+                         End
+                   Else If (Pai386(p)^.Op3t = top_reg) Then
+                          DestroyReg(p, TRegister(longint(twowords(Pai386(p)^.Op2).word2)));
+                End;
+              A_XOR:
+                Begin
+                  If (Pai386(p)^.op1t = top_reg) And
+                     (Pai386(p)^.op2t = top_reg) And
+                     (Pai386(p)^.op1 = Pai386(p)^.op2)
+                    Then
+                      Begin
+                        DestroyReg(p, Tregister(Pai386(p)^.op1));
+                        TmpProp^.Regs[Reg32(Tregister(Pai386(p)^.op1))].typ := Con_Const;
+                        TmpProp^.Regs[Reg32(Tregister(Pai386(p)^.op1))].StartMod := Pointer(0)
+                      End
+                    Else Destroy(p, Pai386(p)^.op2t, Pai386(p)^.op2);
+                End
+              Else
+                Begin
+                  If InstrProp.NCh <> 255
+                    Then
+                      For Cnt := 1 To InstrProp.NCh Do
+                        Case InstrProp.Ch[Cnt] Of
+                          C_None:;
+                          C_Op1: Destroy(p, Pai386(p)^.op1t, Pai386(p)^.op1);
+                          C_Op2: Destroy(p, Pai386(p)^.op2t, Pai386(p)^.op2);
+                          C_Op3: Destroy(p, Pai386(p)^.op2t, Pointer(Longint(TwoWords(Pai386(p)^.op2).word2)));
+                          C_MemEDI:
+                            Begin
+                              FillChar(TmpRef, SizeOf(TmpRef), 0);
+                              TmpRef.Base := R_EDI;
+                              DestroyRefs(p, TmpRef, R_NO)
+                            End;
+                          C_EAX..C_EDI: DestroyReg(p, TCh2Reg(InstrProp.Ch[Cnt]));
+                          C_Flags, C_FPU:;
+                        End
+                    Else
+                      Begin
+                        DestroyAllRegs(p);
+                      End;
+                End;
+            End;
+          End
+        Else
+          Begin
+            DestroyAllRegs(p);
+          End;
+      End;
+      Inc(InstrCnt);
+      p := Pai(p^.next);
+    End;
+End;
+
+Procedure OptimizeBlock(First, Last: Pai);
+{marks the instructions that can be removed by RemoveInstructs. They're not
+ removed immediately because sometimes an instruction needs to be checked in
+ two different sequences}
+Var Cnt, Cnt2: Longint;
+    p, hp1, hp2: Pai;
+Begin
+  p := First;
+  While (p <> Pai(Last^.Next)) Do
+    Begin
+      Case p^.typ Of
+        ait_label, ait_labeled_instruction:;
+        ait_instruction:
+          Begin
+            Case Pai386(p)^._operator Of
+{$IfDef OptimizeMovs}
+              A_MOV{, A_MOVZX, A_MOVSX}:
+                Begin
+                  Case Pai386(p)^.op1t Of
+{                    Top_Reg:
+                      Case Pai386(p)^.op2t Of
+                        Top_Reg:;
+                        Top_Ref:;
+                      End;}
+                    Top_Ref:
+                      Begin {destination is always a register in this case}
+                        With PPaiProp(p^.line)^.Regs[Reg32(Tregister(Pai386(p)^.op2))] Do
+                          Begin
+                            If Assigned(p^.last) And
+                               (PPaiProp(Pai(p^.last)^.line)^.Regs[Reg32(TRegister(Pai386(p)^.op2))].typ = con_ref) Then
+   {so we don't try to check a sequence when the register only contains a constant}
+                               If CheckSequence(p, TRegister(Pai386(p)^.op2), Cnt) And
+                                  (Cnt > 0)
+                                 Then
+                                   Begin
+                                     hp1 := nil;
+   {although it's perfectly ok to remove an instruction which doesn't contain
+    the register that we've just checked (CheckSequence takes care of that),
+    the sequence containing this other register should also be completely
+    checked and removed, otherwise we may get situations like this:
+
+      movl 12(%ebp), %edx                       movl 12(%ebp), %edx
+      movl 16(%ebp), %eax                       movl 16(%ebp), %eax
+      movl 8(%edx), %edx                        movl 8(%edx), %edx
+      movl (%eax), eax                          movl (%eax), eax
+      cmpl %eax, %edx                           cmpl %eax, %edx
+      jnz  l123           getting converted to  jnz  l123
+      movl 12(%ebp), %edx                       movl 4(%eax), eax
+      movl 16(%ebp), %eax
+      movl 8(%edx), %edx
+      movl 4(%eax), eax}
+                                     hp2 := p;
+                                     For Cnt2 := 1 to Cnt Do
+                                       Begin
+                                         If Not(Pai(p)^.typ In [ait_stabs, ait_stabn, ait_stab_function_name]) Then
+                                           Begin
+                                             If (hp1 = nil) And
+                                                Not(RegInInstruction(Tregister(Pai386(hp2)^.op2), p))
+                                               Then hp1 := p;
+                                             PPaiProp(p^.line)^.CanBeRemoved := True;
+                                           End;
+                                         p := Pai(p^.next);
+                                       End;
+                                     If hp1 <> nil Then p := hp1;
+                                     Continue;
+                                   End
+                                 Else
+                                   If (Cnt > 0) And
+                                      (PPaiProp(p^.line)^.CanBeRemoved) Then
+                                     Begin
+                                       hp2 := p;
+                                       For Cnt2 := 1 to Cnt Do
+                                         Begin
+                                           If RegInInstruction(Tregister(Pai386(hp2)^.op2), p)
+                                             Then PPaiProp(p^.Line)^.CanBeRemoved := False;
+                                           p := Pai(p^.Next)
+                                         End;
+                                       Continue;
+                                     End;
+                          End;
+                      End;
+                    Top_Const:
+                      Begin
+                        Case Pai386(p)^.op2t Of
+                          Top_Reg:
+                            Begin
+                              If Assigned(p^.last) Then
+                                With PPaiProp(Pai(p^.last)^.line)^.Regs[Reg32(TRegister(Pai386(p)^.op2))] Do
+                                  If (Typ = Con_Const) And
+                                     (StartMod = Pai386(p)^.op1) Then
+                                    PPaiProp(p^.line)^.CanBeRemoved := True;
+                            End;
+                          Top_Ref:;
+                        End;
+                      End;
+                  End;
+                End;
+{$EndIf OptimizeMovs}
+              A_XOR:
+                Begin
+                  If (Pai386(p)^.op1t = top_reg) And
+                     (Pai386(p)^.op2t = top_reg) And
+                     (Pai386(p)^.op1 = Pai386(p)^.op2) And
+                     Assigned(p^.last) And
+                     (PPaiProp(Pai(p^.last)^.line)^.Regs[Reg32(Tregister(Pai386(p)^.op1))].typ = con_const) And
+                     (PPaiProp(Pai(p^.last)^.line)^.Regs[Reg32(Tregister(Pai386(p)^.op1))].StartMod = Pointer(0))
+                    Then PPaiProp(p^.line)^.CanBeRemoved := True
+                End
+            End
+          End;
+      End;
+      p := Pai(p^.next);
+    End;
+End;
+
+Procedure RemoveInstructs(First, Last: Pai);
+{Removes the marked instructions and disposes the PPaiProps of the other
+ instructions, restoring theirline number}
+Var p, hp1: Pai;
+    TmpLine, InstrCnt: Longint;
+Begin
+  p := First;
+  InstrCnt := 1;
+  While (p <> Pai(Last^.Next)) Do
+    If PPaiProp(p^.line)^.CanBeRemoved
+      Then
+        Begin
+          If (InstrCnt > NrOfPaiFast) Then
+            Dispose(PPaiProp(p^.Line));
+          hp1 := Pai(p^.Next);
+          AsmL^.Remove(p);
+          Dispose(p, Done);
+          p := hp1;
+          Inc(InstrCnt)
+        End
+      Else
+        Begin
+          If (InstrCnt > NrOfPaiFast)
+            Then
+              Begin
+                TmpLine := PPaiProp(p^.Line)^.LineSave;
+                Dispose(PPaiProp(p^.Line));
+                p^.Line := TmpLine;
+              End
+            Else p^.Line := PPaiProp(p^.Line)^.LineSave;
+          p := Pai(p^.Next);
+          Inc(InstrCnt)
+        End;
+  If (NrOfPaiFast > 0) Then
+{$IfDef TP}
+    Freemem(PaiPropBlock, NrOfPaiFast*(((SizeOf(TPaiProp)+1)div 2)*2))
+{$Else}
+    FreeMem(PaiPropBlock, NrOfPaiFast*(((SizeOf(TPaiProp)+3)div 4)*4))
+{$EndIf TP}
+End;
+
+Function InitReloadOpt(AsmL: PAasmOutput): Boolean;
+{reserves memory for the PPaiProps in one big memory block when not using
+ TP, returns False if not enough memory is available for the optimizer in all
+ cases}
+Var p: Pai;
+Begin
+  P := Pai(AsmL^.First);
+  NrOfPaiObjs := 1;
+  While (P <> Pai(AsmL^.Last)) Do
+    Begin
+      Inc(NrOfPaiObjs);
+      P := Pai(P^.next)
+    End;
+{$IfDef TP}
+  If (MemAvail < (SizeOf(TPaiProp)*NrOfPaiObjs))
+    {this doesn't have to be one contiguous block}
+    Then InitReloadOpt := False
+    Else
+      Begin
+        InitReloadOpt := True;
+        If (MaxAvail < 65520)
+          Then NrOfPaiFast := MaxAvail Div (((SizeOf(TPaiProp)+1) div 2)*2)
+          Else NrOfPaiFast := 65520 Div (((SizeOf(TPaiProp)+1) div 2)*2);
+        If (NrOfPaiFast > 0) Then
+           GetMem(PaiPropBlock, NrOfPaiFast*(((SizeOf(TPaiProp)+1) div 2)*2));
+      End;
+{$Else}
+{Uncomment the next line to see how much memory the reloading optimizer needs}
+{  Writeln((NrOfPaiObjs*(((SizeOf(TPaiProp)+3)div 4)*4)));}
+{no need to check mem/maxavail, we've got as much virtual memory as we want}
+  InitReloadOpt := True;
+  GetMem(PaiPropBlock, NrOfPaiObjs*(((SizeOf(TPaiProp)+3)div 4)*4));
+  InitReloadOpt := True;
+  NrOfPaiFast := NrOfPaiObjs;
+ {$EndIf TP}
+End;
+
+Var BlockEnd: Pai;
+
+Begin {ReloadOpt}
+  If InitReloadOpt(AsmL)
+    Then
+      Begin
+        BlockEnd := CreateRegs(Pai(AsmL^.First));
+        OptimizeBlock(Pai(AsmL^.First), BlockEnd);
+        RemoveInstructs(Pai(AsmL^.First), BlockEnd)
+      End;
+End;
+
+{
+ $Log$
+ Revision 1.1  1998-03-25 11:18:12  root
+ Initial revision
+
+ Revision 1.22  1998/03/24 21:48:29  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.21  1998/03/11 15:45:35  florian
+   * -Oa problem solved
+
+ Revision 1.20  1998/03/10 01:17:13  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 16:46:27  jonas
+   * fixed bug with uncertain optimizations when moving data among variables using movsl
+
+ Revision 1.18  1998/03/04 16:42:00  jonas
+   * bugfix in destroyrefs and fixed a potential bug in createregs
+
+ Revision 1.17  1998/03/03 20:33:29  jonas
+   * TContent record now only occupies 8 bytes anymore
+
+ Revision 1.15  1998/03/03 01:08:13  florian
+   * bug0105 and bug0106 problem solved
+
+ Revision 1.14  1998/03/02 21:35:16  jonas
+   * added comments from last update
+
+ Revision 1.13  1998/03/02 21:29:06  jonas
+   * redesigned TContent record so it occupies only 13 bytes anymore (was about 18)
+   * store TPaiProps of 16 and 8 bit registers in those of the 32 bit regs
+   * fixed a small bug which prevented some optimizes from being performed
+   * store TPaiProps in one big array instead of in seperate records
+   * warning: TP version not tested because I only have TP, not BP (-> no proteced mode apps)
+
+ Revision 1.12  1998/02/24 21:18:13  jonas
+   * file name back to lower case
+
+ Revision 1.4  1998/02/24 20:32:12  jonas
+   * added comments from latest commit
+
+ Revision 1.3  1998/02/24 20:27:51  jonas
+   * if a register is being written to memory, it's contents aren't destroyed
+    (wherever it's been written to, its contents are up-to-date)
+   * changed the order in which some functions/procedure are defined, because some
+    of them are now used by aopt386.pas
+
+ Revision 1.11  1998/02/19 22:46:54  peter
+   * Fixed linebreaks
+
+ Revision 1.10  1998/02/13 10:34:31  daniel
+ * Made Motorola version compilable.
+ * Fixed optimizer
+
+ Revision 1.9  1998/02/12 17:18:49  florian
+   * fixed to get remake3 work, but needs additional fixes (output, I don't like
+     also that aktswitches isn't a pointer)
+
+ Revision 1.8  1998/02/12 11:49:37  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.7  1998/02/07 10:11:19  michael
+   * RefsEqual made less harsh:
+
+       * when something is written to x(%ebp), registers which contain
+         a pointer that isn't "x(%ebp)"-based isn't destroyed
+
+       * when something is written to a pointer location, registers
+         which contain the contents of x(%ebp) aren't destroyed
+
+
+ Revision 1.6  1998/01/12 17:45:20  jonas
+   * merged DisposeProps and RemoveInstructs procedures (speed!)
+
+ Revision 1.5  1998/01/11 22:51:30  jonas
+   * back to unix linebreaks...(hate it! :)
+
+ Revision 1.4 1998/01/11 22:50:10  jonas
+   * all floating point store operations now change op1 instead of the fpu regs
+
+ Revision 1.3  1998/01/11 14:40:04  jonas
+   * bugfix in optimize procedure (too many instructions were removed in certain cases)
+
+ Revision 1.1  1997/12/30 21:10:34  jonas
+   * changed back to unix/linux line breaks
+
+
+  Pre-CVS log:
+
+
+   JM   Jonas Maebe
+
+  + feature added
+  - removed
+  * bug fixed or changed
+
+  History (started on 2nd December 1997):
+       2nd December 1997:
+         + initial version (JM)
+         + removes redundant "xor %reg, %reg"'s (JM)
+       3rd December 1997:
+         + removes certain redundant movs (still bugged) (JM)
+         * A_REP now destroys ECX
+       4th December 1997:
+         * fixed bugs in mov-removal (still bugged) (JM)
+       5th December 1997:
+         * fixed more bugs in mov-removal (a compiler compiled with these
+           optimizations now can compile itself suyccessfully!) and enhanced
+           it (introducing new bugs, which have to be fixed again...) (JM)
+         * A_AND and A_OR now destroy op2 instead of op1 <g> (JM)
+       6th December 1997:
+         * A_PUSHAD now only destroys ESP instead of all registers (JM)
+         * A_REPE and A_REPNE now also destroy ECX (JM)
+         * Rewrote some procedures so it's a bit more modular and easier/
+           cleaner/possible to do some optimizations, but it's slower (JM)
+         * enabled mov-reloading optimization for A_MOVZX and A_MOVSX
+           (actually it's already 7 December, 1:25 am in the mean time :) (JM)
+       7th December 1997:
+         * All instructions okayed by CheckSequence are now being removed (JM)
+
+
+       To Do:
+         * special case for A_XCHG
+         * implementation of ModReg comparing
+         * special case for lea
+         * fpu optimizing
+         * active optimizing (ie. change certain register allocations)
+         * make DestroyRefs a little less harsh
+         * bug fixes?
+}

compiler/aopt386.pas

@@ -0,0 +1,1669 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl and Jonas Maebe
+
+    This unit does optimizations on the assembler code for i386+
+
+    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 aopt386;
+
+  interface
+
+    uses aasm;
+
+    { does simple optimizations like jumps and remove pop/pushes }
+    procedure peepholeopt(asml : paasmoutput);
+
+  implementation
+
+    uses
+       cobjects,globals,symtable,strings,verbose,hcodegen
+{$ifdef i386}
+       ,i386
+       ,cgi386
+{$else}
+{$endif}
+       ;
+
+  Type
+{$ifdef tp}
+       TLabelTable = Array[0..10000] Of Pai;
+{$else}
+       TLabelTable = Array[0..2500000] Of Pai;
+{$endif}
+       PLabelTable = ^TLabelTable;
+
+Var LoLab, HiLab, LabDif: Longint;
+    LTable: PLabelTable;
+
+  Function RefsEqual(const r1,r2 : treference) : boolean;
+
+  begin
+     if r1.isintvalue
+       then RefsEqual:=r2.isintvalue and (r1.offset=r2.offset)
+       else if (r1.offset=r2.offset) and (r1.base=r2.base) and
+               (r1.index=r2.index) and (r1.segment=r2.segment) and
+               (r1.scalefactor=r2.scalefactor)
+              then
+                begin
+                  if assigned(r1.symbol)
+                    then RefsEqual:=assigned(r2.symbol) and (r1.symbol^=r2.symbol^)
+                    else RefsEqual:=not(assigned(r2.symbol));
+                end
+              Else RefsEqual := False;
+  end;
+
+{$i aopt386.inc}
+{aopt386.inc contains the reloading optimizer}
+
+  Function FindLabel(L: PLabel; Var hp: Pai): Boolean;
+
+  {searches for the specified label starting from hp as long as the
+   encountered instructions are labels, to be able to optimize constructs like
+
+   jne l2              jmp l2
+   jmp l3     and      l1:
+   l1:                 l2:
+   l2:}
+
+  Var TempP: Pai;
+
+  Begin
+    TempP := hp;
+    While Assigned(TempP) and (pai(TempP)^.typ = ait_label) Do
+      If (pai_label(TempP)^.l <> L)
+        Then TempP := Pai(TempP^.next)
+        Else
+          Begin
+            hp := TempP;
+            FindLabel := True;
+            exit
+          End;
+    FindLabel := False
+  End;
+
+  Function PowerOf2(L: Longint): Longint;
+  Var Counter, TempVal: Longint;
+  Begin
+    TempVal := 1;
+    For Counter := 1 to L Do
+      TempVal := TempVal * 2;
+    PowerOf2 := TempVal;
+  End;
+
+  Procedure DoOptimize(asml : paasmoutput);
+
+  var
+      p,hp1,hp2 : pai;
+      TmpBool1, TmpBool2: Boolean;
+
+      TmpRef: PReference;
+
+
+    { inserts new_one between prev and foll }
+    Procedure InsertLLItem(prev, foll, new_one: PLinkedList_Item);
+    Begin
+      If Assigned(prev)
+        Then
+          If Assigned(foll)
+            Then
+              Begin
+                If Assigned(new_one) Then
+                  Begin
+                    new_one^.last := prev;
+                    new_one^.next := foll;
+                    prev^.next := new_one;
+                    foll^.last := new_one;
+                  End;
+              End
+            Else AsmL^.Concat(new_one)
+        Else If Assigned(Foll) Then AsmL^.Insert(new_one)
+    End;
+
+
+    Function GetNextInstr(hp: Pai): Pai;
+    {skips all labels and returns the next "real" instruction; it is assumed
+     that hp is of the type ait_label}
+    Begin
+      While assigned(hp^.next) and (pai(hp^.next)^.typ = ait_label) Do
+        hp := pai(hp^.next);
+      If assigned(hp^.next)
+        Then GetNextInstr := pai(hp^.next)
+        Else GetNextInstr := hp;
+    End;
+
+    Procedure GetFinalDestination(hp: pai_labeled);
+    {traces sucessive jumps to their final destination and sets it, e.g.
+    je l1                je l3
+    <code>               <code>
+    l1:       becomes    l1:
+    je l2                je l3
+    <code>               <code>
+    l2:                  l2:
+    jmp l3               jmp l3}
+
+    Var p1: pai;
+
+    Begin
+      If (hp^.lab^.nb >= LoLab) and
+         (hp^.lab^.nb <= HiLab) and   {range check, necessary?}
+         (Pointer(LTable^[hp^.lab^.nb-LoLab]) <> Pointer(0)) Then
+        Begin
+          p1 := LTable^[hp^.lab^.nb-LoLab]; {the jump's destination}
+          p1 := GetNextInstr(p1);
+          If (pai(p1)^.typ = ait_labeled_instruction) and
+             ((pai_labeled(p1)^._operator = A_JMP) or
+              (pai_labeled(p1)^._operator = hp^._operator))
+            Then
+              Begin
+                GetFinalDestination(pai_labeled(p1));
+                Dec(hp^.lab^.refcount);
+                If (hp^.lab^.refcount = 0) Then
+                  hp^.lab^.is_used := False;
+                hp^.lab := pai_labeled(p1)^.lab;
+                Inc(hp^.lab^.refcount);
+              End
+        End
+    End;
+
+    Function IsGP32Reg(Reg: TRegister): Boolean;
+    {Checks if the register is a 32 bit general purpose register}
+    Begin
+      If (Reg >= R_EAX) and (Reg <= R_EBX)
+        Then IsGP32Reg := True
+        Else IsGP32reg := False
+    End;
+
+  type  twowords=record
+                word1,word2:word;
+            end;
+
+  begin
+    p:=pai(asml^.first);
+    while assigned(p) do
+       begin
+         if (p^.typ=ait_labeled_instruction) then
+           begin
+  {the following if-block removes all code between a jmp and the next label,
+   because it can never be executed}
+             If (pai_labeled(p)^._operator = A_JMP) Then
+               Begin
+                 hp1 := pai(p^.next);
+                 While Assigned(hp1) and (hp1^.typ <> ait_label) Do
+                   Begin
+                     AsmL^.Remove(hp1);
+                     Dispose(hp1, done);
+                     hp1 := pai(p^.next);
+                   End;
+               End;
+             if (assigned(p^.next)) then
+               begin
+                 hp2 := pai(p^.next^.next);
+                 if (pai(p^.next)^.typ=ait_labeled_instruction) and
+                    (pai_labeled(p^.next)^._operator=A_JMP) and
+                    FindLabel(pai_labeled(p)^.lab, hp2) then
+                    begin
+                      case pai_labeled(p)^._operator of
+                        A_JE : pai_labeled(p)^._operator:=A_JNE;
+                        A_JNE : pai_labeled(p)^._operator:=A_JE;
+                        A_JL : pai_labeled(p)^._operator:=A_JGE;
+                        A_JG : pai_labeled(p)^._operator:=A_JLE;
+                        A_JLE : pai_labeled(p)^._operator:=A_JG;
+                        A_JGE : pai_labeled(p)^._operator:=A_JL;
+                        A_JNZ : pai_labeled(p)^._operator:=A_JZ;
+                        A_JNO : pai_labeled(p)^._operator:=A_JO;
+                        A_JZ : pai_labeled(p)^._operator:=A_JNZ;
+                        A_JS : pai_labeled(p)^._operator:=A_JNS;
+                        A_JNS : pai_labeled(p)^._operator:=A_JS;
+                        A_JO : pai_labeled(p)^._operator:=A_JNO;
+                        A_JC : pai_labeled(p)^._operator:=A_JNC;
+                        A_JNC : pai_labeled(p)^._operator:=A_JC;
+                        A_JA : pai_labeled(p)^._operator:=A_JBE;
+                        A_JAE : pai_labeled(p)^._operator:=A_JB;
+                        A_JB : pai_labeled(p)^._operator:=A_JAE;
+                        A_JBE : pai_labeled(p)^._operator:=A_JA;
+                        else
+                          begin
+                            If (LabDif <> 0) Then GetFinalDestination(pai_labeled(p));
+                            p:=pai(p^.next);
+                            continue;
+                          end;
+                      end;
+                      Dec(pai_label(hp2)^.l^.refcount);
+                      If (pai_label(hp2)^.l^.refcount = 0) Then
+                        Begin
+                          pai_label(hp2)^.l^.is_used := False;
+                          AsmL^.remove(hp2);
+                          Dispose(hp2, done);
+                        End;
+                      pai_labeled(p)^.lab:=pai_labeled(p^.next)^.lab;
+                      Inc(pai_labeled(p)^.lab^.refcount);
+                      hp1:=pai(p^.next);
+                      asml^.remove(hp1);
+                      dispose(hp1,done);
+                      If (LabDif <> 0) Then GetFinalDestination(pai_labeled(p));
+                    end
+                  else
+                    Begin
+                      hp2:=pai(p^.next);
+                      if FindLabel(pai_labeled(p)^.lab, hp2) then
+                        begin
+                          hp1:=pai(hp2^.next);
+                          asml^.remove(p);
+                          dispose(p,done);
+                          If Not(pai_label(hp2)^.l^.is_used) Then
+                            Begin
+                              AsmL^.remove(hp2);
+                              Dispose(hp2, done);
+                            End;
+                          p:=hp1;
+                          continue;
+                        end;
+                      If (LabDif <> 0) Then GetFinalDestination(pai_labeled(p));
+                    end;
+               end
+           end
+          else
+            if p^.typ=ait_instruction
+              Then
+                Begin
+                   If (Pai386(p)^.op1t = top_ref) Then
+                     With TReference(Pai386(p)^.op1^) Do
+                       Begin
+                         If (base = R_NO) And
+                            (scalefactor = 1)
+                           Then
+                             Begin
+                               base := index;
+                               index := r_no
+                             End
+                       End;
+                   If (Pai386(p)^.op2t = top_ref) Then
+                     With TReference(Pai386(p)^.op2^) Do
+                       Begin
+                         If (base = R_NO) And
+                            (scalefactor = 1)
+                           Then
+                             Begin
+                               base := index;
+                               index := r_no
+                             End
+                       End;
+                   Case Pai386(p)^._operator Of
+                     A_AND:
+                       Begin
+                         If (Pai386(p)^.op1t = top_const) And
+                            (Pai386(p)^.op2t = top_reg) And
+                            Assigned(p^.next) And
+                            (Pai(p^.next)^.typ = ait_instruction) And
+                            (Pai386(p^.next)^._operator = A_AND) And
+                            (Pai386(p^.next)^.op1t = top_const) And
+                            (Pai386(p^.next)^.op2t = top_reg) And
+                            (Pai386(p)^.op2 = Pai386(p^.next)^.op2)
+                           Then
+{change "and const1, reg; and const2, reg" to "and (const1 and const2), reg"}
+                             Begin
+                               Pai386(p)^.op1 := Pointer(Longint(Pai386(p)^.op1) And Longint(Pai386(p^.next)^.op1));
+                               hp1 := Pai(p^.next);
+                               AsmL^.Remove(hp1);
+                               Dispose(hp1, Done)
+                             End
+                         Else
+                           If (Pai386(p)^.op2t = top_reg) And
+                              Assigned(p^.next) And
+                              (Pai(p^.next)^.typ = ait_labeled_instruction)
+                             Then Pai386(p)^._operator := A_TEST;
+{change "and x, reg; jxx" to "test x, reg}
+                       End;
+                     A_CMP:
+                       Begin
+                         If (Pai386(p)^.op1t = top_const) And
+                            (Pai386(p)^.op2t = top_reg) And
+                            (Pai386(p)^.op1 = Pointer(0)) Then
+                        {change "cmp $0, %reg" to "test %reg, %reg"}
+                           Begin
+                             Pai386(p)^._operator := A_TEST;
+                             Pai386(p)^.opxt := Top_reg+Top_reg shl 4;
+                             Pai386(p)^.op1 := Pai386(p)^.op2;
+                           End;
+                       End;
+                     A_FSTP:
+                       Begin
+                         If (Pai386(p)^.op1t = top_ref) And
+                            Assigned(p^.next) And
+                            (Pai(p^.next)^.typ = ait_instruction) And
+                            (Pai386(p^.next)^._operator = A_FLD) And
+                            (Pai386(p^.next)^.op1t = top_ref) And
+                            (Pai386(p)^.Size = Pai386(p)^.Size) And
+                            RefsEqual(TReference(Pai386(p)^.op1^), TReference(Pai386(p^.next)^.op1^))
+                           Then
+                             Begin
+                               hp1 := pai(p^.next^.next);
+                               If Assigned(hp1) And
+                                  (hp1^.typ = ait_instruction) And
+                                  ((Pai386(hp1)^._operator = A_LEAVE) Or
+                                   (Pai386(hp1)^._operator = A_RET)) And
+                                  (TReference(Pai386(p)^.op1^).Base = ProcInfo.FramePointer) And
+                                  (TReference(Pai386(p)^.op1^).Offset >= ProcInfo.RetOffset) And
+                                  (TReference(Pai386(p)^.op1^).Index = R_NO)
+                                 Then
+                                   Begin
+                                     hp2 := Pai(p^.next);
+                                     AsmL^.Remove(p);
+                                     AsmL^.Remove(hp2);
+                                     Dispose(p, Done);
+                                     Dispose(hp2, Done);
+                                     p := hp1;
+                                     Continue
+                                   End
+                                 Else
+                                   Begin
+                                     Pai386(p)^._operator := A_FST;
+                                     hp1 := Pai(p^.next);
+                                     AsmL^.Remove(hp1);
+                                     Dispose(hp1, done)
+                                   End
+                             End;
+                       End;
+                     A_IMUL:
+                       {changes certain "imul const, %reg"'s to lea sequences}
+                       Begin
+                         If (Pai386(p)^.op1t = Top_Const) And
+                            (Pai386(p)^.op2t = Top_Reg) And
+                            (Pai386(p)^.Size = S_L) And
+                            ((Pai386(p)^.op3t = Top_Reg) or
+                             (Pai386(p)^.op3t = Top_None)) And
+                            (Opt_Processors < PentiumPro) And
+                            (Longint(Pai386(p)^.op1) <= 12) And
+                            Not(CS_LittleSize in AktSwitches) And
+                            ((Assigned(p^.next) And
+                              Not((Pai(p^.next)^.typ = ait_labeled_instruction) And
+                                  ((pai_labeled(p^.next)^._operator = A_JO) or
+                                   (pai_labeled(p^.next)^._operator = A_JNO)))) or
+                            Not(Assigned(p^.next))) Then
+                           Begin
+                             New(TmpRef);
+                             TmpRef^.segment := R_DEFAULT_SEG;
+                             TmpRef^.symbol := nil;
+                             TmpRef^.isintvalue := false;
+                             TmpRef^.offset := 0;
+                             Case Longint(Pai386(p)^.op1) Of
+                               3: Begin
+                                    TmpRef^.base := TRegister(Pai386(p)^.op2);
+                                    TmpRef^.Index := TRegister(Pai386(p)^.op2);
+                                    TmpRef^.ScaleFactor := 2;
+                                    If (Pai386(p)^.op3t = Top_None)
+                                      Then hp1 := New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef, TRegister(Pai386(p)^.op2)))
+                                      Else hp1 := New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                       TRegister(twowords(Pai386(p)^.op2).word2)));
+                                    hp1^.line := p^.line;
+                                    InsertLLItem(p^.last, p^.next, hp1);
+                                    Dispose(p, Done);
+                                    p := hp1;
+                                 End;
+                               5: Begin
+                                    TmpRef^.base := TRegister(Pai386(p)^.op2);
+                                    TmpRef^.Index := TRegister(Pai386(p)^.op2);
+                                    TmpRef^.ScaleFactor := 4;
+                                    If (Pai386(p)^.op3t = Top_None)
+                                      Then hp1 := New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef, TRegister(Pai386(p)^.op2)))
+                                      Else hp1 := New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                       TRegister(twowords(Pai386(p)^.op2).word2)));
+                                    hp1^.line:= p^.line;
+                                    InsertLLItem(p^.last, p^.next, hp1);
+                                    Dispose(p, Done);
+                                    p := hp1;
+                                  End;
+                               6: Begin
+                                    If (Opt_Processors <= i486) Then
+                                      Begin
+                                        TmpRef^.Index := TRegister(Pai386(p)^.op2);
+                                        If (Pai386(p)^.op3t = Top_Reg)
+                                          Then
+                                            Begin
+                                              TmpRef^.base := TRegister(twowords(Pai386(p)^.op2).word2);
+                                              TmpRef^.ScaleFactor := 4;
+                                              hp1 :=  New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                               TRegister(twowords(Pai386(p)^.op2).word2)));
+                                            End
+                                          Else
+                                            Begin
+                                              TmpRef^.base := R_NO;
+                                              TmpRef^.ScaleFactor := 2;
+                                              hp1 :=  New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                               TRegister(Pai386(p)^.op2)));
+                                            End;
+                                        hp1^.line := p^.line;
+                                        InsertLLItem(p, p^.next, hp1);
+                                        New(TmpRef);
+                                        TmpRef^.segment := R_DEFAULT_SEG;
+                                        TmpRef^.symbol := nil;
+                                        TmpRef^.isintvalue := false;
+                                        TmpRef^.offset := 0;
+                                        TmpRef^.Index := TRegister(Pai386(p)^.op2);
+                                        TmpRef^.ScaleFactor := 2;
+                                        If (Pai386(p)^.op3t = Top_Reg)
+                                          Then
+                                            Begin
+                                              TmpRef^.base := R_NO;
+                                              hp1 :=  New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                                TRegister(twowords(Pai386(p)^.op2).word2)));
+                                            End
+                                          Else
+                                            Begin
+                                              TmpRef^.base := TRegister(Pai386(p)^.op2);
+                                              hp1 :=  New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef, TRegister(Pai386(p)^.op2)));
+                                            End;
+                                        hp1^.line := p^.line;
+                                        InsertLLItem(p^.last, p^.next, hp1);
+                                        Dispose(p, Done);
+                                        p := Pai(hp1^.next);
+                                      End
+                                     Else Dispose(TmpRef);
+                                  End;
+                               9: Begin
+                                    TmpRef^.base := TRegister(Pai386(p)^.op2);
+                                    TmpRef^.Index := TRegister(Pai386(p)^.op2);
+                                    TmpRef^.ScaleFactor := 8;
+                                    If (Pai386(p)^.op3t = Top_None)
+                                      Then hp1 := New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef, TRegister(Pai386(p)^.op2)))
+                                      Else hp1 := New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                       TRegister(twowords(Pai386(p)^.op2).word2)));
+                                    hp1^.line := p^.line;
+                                    InsertLLItem(p^.last, p^.next, hp1);
+                                    Dispose(p, Done);
+                                    p := hp1;
+                                  End;
+                               10: Begin
+                                     If (Opt_Processors <= i486) Then
+                                       Begin
+                                         TmpRef^.Index := TRegister(Pai386(p)^.op2);
+                                         If (Pai386(p)^.op3t = Top_Reg)
+                                           Then
+                                             Begin
+                                               TmpRef^.base := TRegister(twowords(Pai386(p)^.op2).word2);
+                                               TmpRef^.ScaleFactor := 8;
+                                               hp1 :=  New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                                Tregister(twowords(Pai386(p)^.op2).word2)));
+                                             End
+                                           Else
+                                             Begin
+                                               TmpRef^.base := R_NO;
+                                               TmpRef^.ScaleFactor := 2;
+                                               hp1 :=  New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                                TRegister(Pai386(p)^.op2)));
+                                            End;
+                                         hp1^.line := p^.line;
+                                         InsertLLItem(p, p^.next, hp1);
+                                         New(TmpRef);
+                                         TmpRef^.segment := R_DEFAULT_SEG;
+                                         TmpRef^.symbol := nil;
+                                         TmpRef^.isintvalue := false;
+                                         TmpRef^.offset := 0;
+                                         TmpRef^.Index := TRegister(Pai386(p)^.op2);
+                                         If (Pai386(p)^.op3t = Top_Reg)
+                                           Then
+                                             Begin
+                                               TmpRef^.ScaleFactor := 2;
+                                               TmpRef^.base := R_NO;
+                                               hp1 :=  New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                                TRegister(twowords(Pai386(p)^.op2).word2)));
+                                             End
+                                           Else
+                                             Begin
+                                               TmpRef^.ScaleFactor := 4;
+                                               TmpRef^.base := TRegister(Pai386(p)^.op2);
+                                               hp1 :=  New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                                TRegister(Pai386(p)^.op2)));
+                                             End;
+                                         hp1^.line := p^.line;
+                                         InsertLLItem(p^.last, p^.next, hp1);
+                                         Dispose(p, Done);
+                                         p := Pai(hp1^.next);
+                                       End
+                                     Else Dispose(TmpRef);
+                                   End;
+                               12: Begin
+                                     If (Opt_Processors <= i486) Then
+                                       Begin
+                                         TmpRef^.Index := TRegister(Pai386(p)^.op2);
+                                         If (Pai386(p)^.op3t = Top_Reg)
+                                           Then
+                                             Begin
+                                               TmpRef^.base := TRegister(twowords(Pai386(p)^.op2).word2);
+                                               TmpRef^.ScaleFactor := 8;
+                                               hp1 :=  New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                                 TRegister(twowords(Pai386(p)^.op2).word2)));
+                                             End
+                                           Else
+                                             Begin
+                                               TmpRef^.base := R_NO;
+                                               TmpRef^.ScaleFactor := 4;
+                                               hp1 :=  New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                                TRegister(Pai386(p)^.op2)));
+                                             End;
+                                         hp1^.line := p^.line;
+                                         InsertLLItem(p, p^.next, hp1);
+                                         New(TmpRef);
+                                         TmpRef^.segment := R_DEFAULT_SEG;
+                                         TmpRef^.symbol := nil;
+                                         TmpRef^.isintvalue := false;
+                                         TmpRef^.offset := 0;
+                                         TmpRef^.Index := TRegister(Pai386(p)^.op2);
+                                         TmpRef^.ScaleFactor := 4;
+                                         If (Pai386(p)^.op3t = Top_Reg)
+                                           Then
+                                              Begin
+                                                TmpRef^.base := R_NO;
+                                                hp1 :=  New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                                 TRegister(twowords(Pai386(p)^.op2).word2)));
+                                             End
+                                           Else
+                                             Begin
+                                               TmpRef^.base := TRegister(Pai386(p)^.op2);
+                                               hp1 :=  New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                                TRegister(Pai386(p)^.op2)));
+                                             End;
+                                         hp1^.line := p^.line;
+                                         InsertLLItem(p^.last, p^.next, hp1);
+                                         Dispose(p, Done);
+                                         p := Pai(hp1^.next);
+                                       End
+                                     Else Dispose(TmpRef);
+                                   End
+                                 Else Dispose(TmpRef);
+                             End;
+                           End;
+                       End;
+                     A_LEA:
+                       Begin
+                       {changes "lea (%reg1), %reg2" into "mov %reg1, %reg2"}
+                         If (PReference(Pai386(p)^.op1)^.Base >= R_EAX) And
+                            (PReference(Pai386(p)^.op1)^.Base <= R_EDI) And
+                            (PReference(Pai386(p)^.op1)^.Index = R_NO) And
+                            (PReference(Pai386(p)^.op1)^.Offset = 0) And
+                            (Not(Assigned(PReference(Pai386(p)^.op1)^.Symbol))) Then
+                           Begin
+                             hp1 := New(Pai386, op_reg_reg(A_MOV, S_L,PReference(Pai386(p)^.op1)^.Base,
+                              TRegister(Pai386(p)^.op2)));
+                             hp1^.line := p^.line;
+                             InsertLLItem(p^.last,p^.next, hp1);
+                             Dispose(p, Done);
+                             p := hp1;
+                             Continue;
+                          End;
+                       End;
+                     A_MOV:
+                       Begin
+                         If (Pai386(p)^.op2t = top_reg) And
+                            (TRegister(Pai386(p)^.op2) In [R_EAX, R_EBX, R_EDX, R_EDI]) And
+                            Assigned(p^.next) And
+                            (Pai(p^.next)^.typ = ait_instruction) And
+                            (Pai386(p^.next)^._operator = A_MOV) And
+                            (Pai386(p^.next)^.op1t = top_reg) And
+                            (Pai386(p^.next)^.op1 = Pai386(p)^.op2)
+                           Then
+                       {we have "mov x, %treg; mov %treg, y}
+                             If (Pai386(p^.next)^.op2t <> top_reg) Or
+                              RegInInstruction(TRegister(Pai386(p^.next)^.op2), Pai(p^.next^.next))
+                               Then
+                      {we've got "mov x, %treg; mov %treg, y; XXX y" (ie. y is used in
+                       the third instruction)}
+                                 Case Pai386(p)^.op1t Of
+                                   top_reg:
+                                 {change "mov %reg, %treg; mov %treg, y"
+                                  to "mov %reg, y"}
+                                     Begin
+                                       Pai386(p^.next)^.op1 := Pai386(p)^.op1;
+                                       hp1 := Pai(p^.next);
+                                       AsmL^.Remove(p);
+                                       Dispose(p, Done);
+                                       p := hp1;
+                                       continue;
+                                     End;
+                                   top_ref:
+                                     If (Pai386(p^.next)^.op2t = top_reg)
+                                       Then
+                                    {change "mov mem, %treg; mov %treg, %reg"
+                                          to "mov mem, %reg"}
+                                         Begin
+                                           Pai386(p)^.op2 := Pai386(p^.next)^.op2;
+                                           hp1 := Pai(p^.next);
+                                           AsmL^.Remove(hp1);
+                                           Dispose(hp1, Done);
+                                           continue;
+                                         End;
+                                 End
+                               Else
+                      {remove an instruction which never makes sense: we've got
+                       "mov mem, %reg1; mov %reg1, %edi" and then EDI isn't used anymore!}
+                                 Begin
+                                   If (TRegister(Pai386(p^.next)^.op2) = R_EDI) And
+                                      Not(Assigned(p^.next^.next) And
+                                          (Pai(p^.next^.next)^.typ = ait_instruction) And
+                                          (Pai386(p^.next^.next)^.op2t = top_reg) And
+                                          (Pai386(p^.next^.next)^.op2 = Pointer(R_ESI))) Then
+                                     Begin
+                                       hp1 := pai(p^.next);
+                                       AsmL^.Remove(hp1);
+                                       Dispose(hp1, Done);
+                                       Continue;
+                                     End
+                                 End
+                           Else
+                         {Change "mov %reg1, %reg2; xxx %reg2, ???" to
+                              "mov %reg1, %reg2; xxx %reg1, ???" to
+                              avoid a write/read penalty}
+                             If (Pai386(p)^.op1t = top_reg) And
+                                (Pai386(p)^.op2t = top_reg) And
+                                Assigned(p^.next) And
+                                (Pai(p^.next)^.typ = ait_instruction) And
+                                (Pai386(p^.next)^.op1t = top_reg) And
+                                (Pai386(p^.next)^.op1 = Pai386(p)^.op2)
+                               Then
+                         {we have "mov %reg1, %reg2; XXX %reg2, ???"}
+                                 Begin
+                                   If ((Pai386(p^.next)^._operator = A_OR) Or
+                                       (Pai386(p^.next)^._operator = A_TEST)) And
+                                      (Pai386(p^.next)^.op2t = top_reg) And
+                                      (Pai386(p^.next)^.op1 = Pai386(p^.next)^.op2)
+                                     Then
+                          {we have "mov %reg1, %reg2; test/or %reg2, %reg2"}
+                                       Begin
+                                         If Assigned(p^.next^.next) And
+                                            (Pai(p^.next^.next)^.typ = ait_labeled_instruction) And
+                                            (TRegister(Pai386(p)^.op2) <> R_ESI)
+                                           Then
+                            {change "mov %reg1, %reg2; test/or %reg2, %reg2; jxx" to
+                                 "test %reg1, %reg1; jxx"}
+                                             Begin
+                                               hp1 := pai(p^.next);
+                                               Pai386(hp1)^.op1 := Pai386(p)^.op1;
+                                               Pai386(hp1)^.op2 := Pai386(p)^.op1;
+                                               AsmL^.Remove(p);
+                                               Dispose(p, done);
+                                               p := hp1;
+                                               continue
+                                             End
+                                           Else
+                             {change "mov %reg1, %reg2; test/or %reg2, %reg2" to
+                              "mov %reg1, %reg2; test/or %reg1, %reg1"}
+                                             Begin
+                                               Pai386(p^.next)^.op1 := Pai386(p)^.op1;
+                                               Pai386(p^.next)^.op2 := Pai386(p)^.op1;
+                                             End;
+                                       End
+                                     Else
+{                                      If (Pai386(p^.next)^._operator
+                                          In [A_PUSH, A_OR, A_XOR, A_AND, A_TEST])}
+                             {change "mov %reg1, %reg2; push/or/xor/... %reg2, ???" to
+                              "mov %reg1, %reg2; push/or/xor/... %reg1, ???"}
+                                 End
+                               Else
+                         {leave out the mov from "mov reg, x(%frame_pointer); leave/ret" (with
+                          x >= RetOffset) as it doesn't do anything (it writes either to a
+                          parameter or to the temporary storage room for the function
+                      result)}
+                                 If Assigned(p^.next) And
+                                    (Pai(p^.next)^.typ = ait_instruction)
+                                   Then
+                                     If ((Pai386(p^.next)^._operator = A_LEAVE) Or
+                                         (Pai386(p^.next)^._operator = A_RET)) And
+                                        (Pai386(p)^.op2t = top_ref) And
+                                        (TReference(Pai386(p)^.op2^).base = ProcInfo.FramePointer) And
+                                        (TReference(Pai386(p)^.op2^).offset >= ProcInfo.RetOffset) And
+                                        (TReference(Pai386(p)^.op2^).index = R_NO) And
+                                        (Pai386(p)^.op1t = top_reg)
+                                       Then
+                                         Begin
+                                          hp1 := Pai(p^.next);
+                                          AsmL^.Remove(p);
+                                          Dispose(p, done);
+                                          p := hp1;
+                                        End
+                                      Else
+                                        If (Pai386(p)^.op1t = top_reg) And
+                                           (Pai386(p)^.op2t = top_ref) And
+                                           (Pai386(p)^.Size = Pai386(p^.next)^.Size) And
+                                           (Pai386(p^.next)^._operator = A_CMP) And
+                                           (Pai386(p^.next)^.op2t = top_ref) And
+                                           RefsEqual(TReference(Pai386(p)^.op2^),
+                                                     TReference(Pai386(p^.next)^.op2^))
+                                          Then
+                   {change "mov reg, mem1; cmp x, mem1" to "mov reg, mem1; cmp x, reg1"}
+                                            Begin
+                                              Dispose(PReference(Pai386(p^.next)^.op2));
+                                              Pai386(p^.next)^.opxt := Pai386(p^.next)^.op1t + (top_reg shl 4);
+                                              Pai386(p^.next)^.op2 := Pai386(p)^.op1
+                                            End;
+                       { Next instruction is also a MOV ? }
+                         If assigned(p^.next) and
+                            (pai(p^.next)^.typ = ait_instruction) and
+                            (Pai386(p^.next)^._operator = A_MOV)
+                           Then
+                             Begin
+                               { Removes the second statement from
+                                   mov %reg, mem
+                                   mov mem, %reg }
+                               If (Pai386(p^.next)^.op1t = Pai386(p)^.op2t) and
+                                  (Pai386(p^.next)^.op2t = Pai386(p)^.op1t) Then
+                                Begin
+                                  If (Pai386(p^.next)^.op1t = top_ref) Then
+                                   TmpBool1 := RefsEqual(TReference(Pai386(p^.next)^.op1^), TReference(Pai386(p)^.op2^))
+                                  Else
+                                   TmpBool1 := Pai386(p^.next)^.op1 = Pai386(p)^.op2;
+                                  If TmpBool1 Then
+                                   Begin
+                                     If (Pai386(p^.next)^.op2t = top_ref) Then
+                                      TmpBool1 := RefsEqual(TReference(Pai386(p^.next)^.op2^),
+                                       TReference(Pai386(p)^.op1^))
+                                     Else
+                                      TmpBool1 := (Pai386(p^.next)^.op2 = Pai386(p)^.op1);
+                                     If TmpBool1 Then
+                                      Begin
+                                        hp1 := pai(p^.next);
+                                        AsmL^.remove(hp1);
+                                        dispose(hp1,done);
+                                      End;
+                                   End;
+                                End
+                               Else
+(*                               {   movl [mem1],reg1
+                                   movl [mem1],reg2
+                                to:
+                                   movl [mem1],reg1
+                                   movl reg1,reg2 }
+                                If (Pai386(p)^.op1t = top_ref) and
+                                   (Pai386(p)^.op2t = top_reg) and
+                                   (Pai386(p^.next)^.op1t = top_ref) and
+                                   (Pai386(p^.next)^.op2t = top_reg) and
+                                   (Pai386(p)^.size = Pai386(p^.next)^.size) and
+                                   RefsEqual(TReference(Pai386(p)^.op1^),TReference(Pai386(p^.next)^.op1^)) and
+                                   (TRegister(Pai386(p)^.op2)<>TReference(Pai386(p^.next)^.op1^).base) and
+                                   (TRegister(Pai386(p)^.op2)<>TReference(Pai386(p^.next)^.op1^).index) then
+                                  Begin
+                                    Dispose(PReference(Pai386(p^.next)^.op1));
+                                    Pai386(p^.next)^.op1:=Pai386(p)^.op2;
+                                    Pai386(p^.next)^.opxt:=Top_reg+Top_reg shl 4;
+                                  End
+                               Else*)
+                               {   movl const1,[mem1]
+                                   movl [mem1],reg1
+                                to:
+                                   movl const1,reg1
+                                   movl reg1,[mem1] }
+                                If (Pai386(p)^.op1t = top_const) and
+                                   (Pai386(p)^.op2t = top_ref) and
+                                   (Pai386(p^.next)^.op1t = top_ref) and
+                                   (Pai386(p^.next)^.op2t = top_reg) and
+                                   (Pai386(p)^.size = Pai386(p^.next)^.size) and
+                                   RefsEqual(TReference(Pai386(p^.next)^.op1^),TReference(Pai386(p)^.op2^)) then
+                                  Begin
+                                    Pai386(p^.next)^.op1:=Pai386(p^.next)^.op2;
+                                    Pai386(p^.next)^.op2:=Pai386(p)^.op2;
+                                    Pai386(p^.next)^.opxt:=Top_reg+Top_ref shl 4;
+                                    Pai386(p)^.op2:=Pai386(p^.next)^.op1;
+                                    Pai386(p)^.opxt:=Top_const+(top_reg shl 4);
+                                  End;
+                             End;
+                           {changes "mov $0, %reg" into "xor %reg, %reg"}
+                           If (Pai386(p)^.op1t = Top_Const) And
+                              (Pai386(p)^.op1 = Pointer(0)) And
+                              (Pai386(p)^.op2t = Top_Reg)
+                             Then
+                               Begin
+                                 Pai386(p)^._operator := A_XOR;
+                                 Pai386(p)^.opxt := Top_Reg+Top_reg shl 4;
+                                 Pai386(p)^.op1 := Pai386(p)^.op2;
+                               End;
+                       End;
+                     A_MOVZX:
+                       Begin
+                       {removes superfluous And's after movzx's}
+                         If (Pai386(p)^.op2t = top_reg) And
+                            Assigned(p^.next) And
+                            (Pai(p^.next)^.typ = ait_instruction) And
+                            (Pai386(p^.next)^._operator = A_AND) And
+                            (Pai386(p^.next)^.op1t = top_const) And
+                            (Pai386(p^.next)^.op2t = top_reg) And
+                            (Pai386(p^.next)^.op2 = Pai386(p)^.op2)
+                           Then
+                             Case Pai386(p)^.Size Of
+                               S_BL, S_BW:
+                                 If (Longint(Pai386(p^.next)^.op1) = $ff)
+                                   Then
+                                     Begin
+                                       hp1 := Pai(p^.next);
+                                       AsmL^.Remove(hp1);
+                                       Dispose(hp1, Done);
+                                     End;
+                               S_WL:
+                                 If (Longint(Pai386(p^.next)^.op1) = $ffff)
+                                   Then
+                                     Begin
+                                       hp1 := Pai(p^.next);
+                                       AsmL^.Remove(hp1);
+                                       Dispose(hp1, Done);
+                                     End;
+                             End;
+                       {changes some movzx constructs to faster synonims (all examples
+                        are given with eax/ax, but are also valid for other registers)}
+                         If (Pai386(p)^.op2t = top_reg) Then
+                           If (Pai386(p)^.op1t = top_reg)
+                             Then
+                                Case Pai386(p)^.size of
+                                  S_BW:
+                                    Begin
+                                      If (TRegister(Pai386(p)^.op1) = Reg16ToReg8(TRegister(Pai386(p)^.op2))) And
+                                         Not(CS_LittleSize In AktSwitches)
+                                        Then
+                                          {Change "movzbw %al, %ax" to "andw $0x0ffh, %ax"}
+                                          Begin
+                                            Pai386(p)^._operator := A_AND;
+                                            Pai386(p)^.opxt := top_const+Top_reg shl 4;
+                                            Longint(Pai386(p)^.op1) := $ff;
+                                            Pai386(p)^.Size := S_W
+                                          End
+                                        Else
+                                          If Assigned(p^.next) And
+                                            (Pai(p^.next)^.typ = ait_instruction) And
+                                            (Pai386(p^.next)^._operator = A_AND) And
+                                            (Pai386(p^.next)^.op1t = top_const) And
+                                            (Pai386(p^.next)^.op2t = top_reg) And
+                                            (Pai386(p^.next)^.op2 = Pai386(p)^.op2)
+                                              Then
+                                                {Change "movzbw %reg1, %reg2; andw $const, %reg2"
+                                                 to "movw %reg1, reg2; andw $(const1 and $ff), %reg2"}
+                                                Begin
+                                                  Pai386(p)^._operator := A_MOV;
+                                                  Pai386(p)^.Size := S_W;
+                                                  Pai386(p)^.op1 := Pointer(Reg8ToReg16(TRegister(Pai386(p)^.op1)));
+                                                  Pai386(p^.next)^.op1 := Pointer(Longint(Pai386(p^.next)^.op1)
+                                                                          And $ff);
+                                                End;
+                                    End;
+                                  S_BL:
+                                    Begin
+                                      If (TRegister(Pai386(p)^.op1) = Reg32ToReg8(TRegister(Pai386(p)^.op2))) And
+                                         Not(CS_LittleSize in AktSwitches)
+                                        Then
+                                          {Change "movzbl %al, %eax" to "andl $0x0ffh, %eax"}
+                                          Begin
+                                            Pai386(p)^._operator := A_AND;
+                                            Pai386(p)^.opxt := top_const+Top_reg shl 4;
+                                            Longint(Pai386(p)^.op1) := $ff;
+                                            Pai386(p)^.Size := S_L;
+                                          End
+                                        Else
+                                          If Assigned(p^.next) And
+                                            (Pai(p^.next)^.typ = ait_instruction) And
+                                            (Pai386(p^.next)^._operator = A_AND) And
+                                            (Pai386(p^.next)^.op1t = top_const) And
+                                            (Pai386(p^.next)^.op2t = top_reg) And
+                                            (Pai386(p^.next)^.op2 = Pai386(p)^.op2)
+                                              Then
+                                                {Change "movzbl %reg1, %reg2; andl $const, %reg2"
+                                                 to "movl %reg1, reg2; andl $(const1 and $ff), %reg2"}
+                                                Begin
+                                                  Pai386(p)^._operator := A_MOV;
+                                                  Pai386(p)^.Size := S_L;
+                                                  Pai386(p)^.op1 := Pointer(Reg8ToReg32(TRegister(Pai386(p)^.op1)));
+                                                  Pai386(p^.next)^.op1 := Pointer(Longint(Pai386(p^.next)^.op1)
+                                                                          And $ff);
+                                                End
+                                              Else
+                                                If IsGP32Reg(TRegister(Pai386(p)^.op2)) And
+                                                   Not(CS_LittleSize in AktSwitches) And
+                                                   (Opt_Processors >= Pentium) And
+                                                   (Opt_Processors < PentiumPro)
+                                                   Then
+                                                     {Change "movzbl %reg1, %reg2" to
+                                                      "xorl %reg2, %reg2; movb %reg1, %reg2" for Pentium and
+                                                       PentiumMMX}
+                                                     Begin
+                                                       hp1 := New(Pai386, op_reg_reg(A_XOR, S_L,
+                                                                  TRegister(Pai386(p)^.op2),
+                                                                  TRegister(Pai386(p)^.op2)));
+                                                       hp1^.line := p^.line;
+                                                       InsertLLItem(p^.last, p, hp1);
+                                                       Pai386(p)^._operator := A_MOV;
+                                                       Pai386(p)^.size := S_B;
+                                                       Pai386(p)^.op2 :=
+                                                           Pointer(Reg32ToReg8(TRegister(Pai386(p)^.op2)));
+                                                       InsertLLItem(p, p^.next, hp2);
+                                                     End;
+                                    End;
+                                  S_WL:
+                                    Begin
+                                      If (TRegister(Pai386(p)^.op1) = Reg32ToReg16(TRegister(Pai386(p)^.op2))) And
+                                         Not(CS_LittleSize In AktSwitches)
+                                        Then
+                                          {Change "movzwl %ax, %eax" to "andl $0x0ffffh, %eax"}
+                                          Begin
+                                            Pai386(p)^._operator := A_AND;
+                                            Pai386(p)^.opxt := top_const+Top_reg shl 4;
+                                            Longint(Pai386(p)^.op1) := $ffff;
+                                            Pai386(p)^.Size := S_L
+                                          End
+                                        Else
+                                          If Assigned(p^.next) And
+                                            (Pai(p^.next)^.typ = ait_instruction) And
+                                            (Pai386(p^.next)^._operator = A_AND) And
+                                            (Pai386(p^.next)^.op1t = top_const) And
+                                            (Pai386(p^.next)^.op2t = top_reg) And
+                                            (Pai386(p^.next)^.op2 = Pai386(p)^.op2)
+                                              Then
+                                                {Change "movzwl %reg1, %reg2; andl $const, %reg2"
+                                                 to "movl %reg1, reg2; andl $(const1 and $ffff), %reg2"}
+                                                Begin
+                                                  Pai386(p)^._operator := A_MOV;
+                                                  Pai386(p)^.Size := S_L;
+                                                  Pai386(p)^.op1 := Pointer(Reg16ToReg32(TRegister(Pai386(p)^.op1)));
+                                                  Pai386(p^.next)^.op1 := Pointer(Longint(Pai386(p^.next)^.op1)
+                                                                          And $ffff);
+                                                End;
+                                    End;
+                                End
+                             Else
+                               If (Pai386(p)^.op1t = top_ref) Then
+                                  Begin
+                                    If (PReference(Pai386(p)^.op1)^.base <> TRegister(Pai386(p)^.op2)) And
+                                       (PReference(Pai386(p)^.op1)^.index <> TRegister(Pai386(p)^.op2)) And
+                                       Not(CS_LittleSize in AktSwitches) And
+                                       IsGP32Reg(TRegister(Pai386(p)^.op2)) And
+                                       (Opt_Processors >= Pentium) And
+                                       (Opt_Processors < PentiumPro) And
+                                       (Pai386(p)^.Size = S_BL)
+                                         Then
+                                           {changes "movzbl mem, %reg" to "xorl %reg, %reg; movb mem, %reg8" for
+                                            Pentium and PentiumMMX}
+                                           Begin
+                                             hp1 := New(Pai386,op_reg_reg(A_XOR, S_L, TRegister(Pai386(p)^.op2),
+                                             TRegister(Pai386(p)^.op2)));
+                                             hp1^.line := p^.line;
+                                             Pai386(p)^._operator := A_MOV;
+                                             Pai386(p)^.size := S_B;
+                                             Pai386(p)^.op2 := Pointer(Reg32ToReg8(TRegister(Pai386(p)^.op2)));
+                                             InsertLLItem(p^.last, p, hp1);
+                                           End
+                                         Else
+                                           If Assigned(p^.next) And
+                                              (Pai(p^.next)^.typ = ait_instruction) And
+                                              (Pai386(p^.next)^._operator = A_AND) And
+                                              (Pai386(p^.next)^.op1t = Top_Const) And
+                                              (Pai386(p^.next)^.op2t = Top_Reg) And
+                                              (Pai386(p^.next)^.op2 = Pai386(p)^.op2) Then
+                                                Begin
+                                                  Pai386(p)^._operator := A_MOV;
+                                                  Case Pai386(p)^.Size Of
+                                                    S_BL:
+                                                      Begin
+                                                        Pai386(p)^.Size := S_L;
+                                                        Pai386(p^.next)^.op1 := Pointer(Longint(Pai386(p^.next)^.op1)
+                                                                                And $ff);
+                                                      End;
+                                                    S_WL:
+                                                      Begin
+                                                        Pai386(p)^.Size := S_L;
+                                                        Pai386(p^.next)^.op1 := Pointer(Longint(Pai386(p^.next)^.op1)
+                                                                                        And $ffff);
+                                                      End;
+                                                    S_BW:
+                                                      Begin
+                                                        Pai386(p)^.Size := S_W;
+                                                        Pai386(p^.next)^.op1 := Pointer(Longint(Pai386(p^.next)^.op1)
+                                                                                And $ff);
+                                                      End;
+                                                  End;
+                                                End;
+                                        End;
+                       End;
+                     {
+                     A_POP:
+                       Begin
+                         if (assigned(p^.next)) and
+                            (pai(p^.next)^.typ=ait_instruction) and
+                            (Pai386(p^.next)^._operator=A_PUSH) and
+                            (Pai386(p^.next)^.op1=Pai386(p)^.op1) then
+                              begin
+                                hp2:=pai(p^.next^.next);
+                                hp1:=pai(p^.next);
+                                asml^.remove(p);
+                                asml^.remove(hp1);
+                                dispose(p,done);
+                                dispose(hp1,done);
+                                p:=hp2;
+                                continue;
+                              end;
+                       end;
+                     }
+                     A_PUSH:
+                       Begin
+                         If (Pai386(p)^.size = S_W) And
+                            (Pai386(p)^.op1t = Top_Const) And
+                            Assigned(p^.next) And
+                            (Pai(p^.next)^.typ = ait_instruction) And
+                            (Pai386(p^.next)^._operator = A_PUSH) And
+                            (Pai386(p^.next)^.op1t = Top_Const) And
+                            (Pai386(p^.next)^.size = S_W) Then
+                              Begin
+                                hp1 := Pai(p^.next);
+                                Pai386(p)^.Size := S_L;
+                                Pai386(p)^.op1 := Pointer(Longint(Pai386(p)^.op1) shl 16 + Longint(Pai386(hp1)^.op1));
+                                AsmL^.Remove(hp1);
+                                Dispose(hp1, Done)
+                              End;
+                       End;
+                     A_SHL, A_SAL:
+                       Begin
+                         If (Pai386(p)^.op1t = Top_Const) And
+                            (Pai386(p)^.op2t = Top_Reg) And
+                            (Pai386(p)^.Size = S_L) And
+                            (Longint(Pai386(p)^.op1) <= 3)
+                       {Changes "shl const, %reg32; add const/reg, %reg32" to one lea statement}
+                           Then
+                             Begin
+                               TmpBool1 := True; {should we check the next instruction?}
+                               TmpBool2 := False; {have we found an add/sub which could be
+                                                   integrated in the lea?}
+                               New(TmpRef);
+                               TmpRef^.segment := R_DEFAULT_SEG;
+                               TmpRef^.base := R_NO;
+                               TmpRef^.index := TRegister(Pai386(p)^.op2);
+                               TmpRef^.scalefactor := PowerOf2(Longint(Pai386(p)^.op1));
+                               TmpRef^.symbol := nil;
+                               TmpRef^.isintvalue := false;
+                               TmpRef^.offset := 0;
+                               While  TmpBool1 And
+                                      Assigned(p^.next) And
+                                      (Pai(p^.next)^.typ = ait_instruction) And
+                                      ((Pai386(p^.next)^._operator = A_ADD) Or
+                                       (Pai386(p^.next)^._operator = A_SUB)) And
+                                      (Pai386(p^.next)^.op2t = Top_Reg) And
+                                      (Pai386(p^.next)^.op2 = Pai386(p)^.op2) Do
+                                  Begin
+                                    TmpBool1 := False;
+                                    If (Pai386(p^.next)^.op1t = Top_Const)
+                                      Then
+                                        Begin
+                                          TmpBool1 := True;
+                                          TmpBool2 := True;
+                                          If Pai386(p^.next)^._operator = A_ADD
+                                            Then Inc(TmpRef^.offset, Longint(Pai386(p^.next)^.op1))
+                                            Else Dec(TmpRef^.offset, Longint(Pai386(p^.next)^.op1));
+                                          hp1 := Pai(p^.next);
+                                          AsmL^.Remove(hp1);
+                                          Dispose(hp1, Done);
+                                        End
+                                      Else
+                                        If (Pai386(p^.next)^.op1t = Top_Reg) And
+                                           (Pai386(p^.next)^._operator = A_ADD) And
+                                           (TmpRef^.base = R_NO) Then
+                                          Begin
+                                            TmpBool1 := True;
+                                            TmpBool2 := True;
+                                            TmpRef^.base := TRegister(Pai386(p^.next)^.op1);
+                                            hp1 := Pai(p^.next);
+                                            AsmL^.Remove(hp1);
+                                            Dispose(hp1, Done);
+                                          End;
+                                  End;
+                                If TmpBool2 Or
+                                   ((Opt_Processors < PentiumPro) And
+                                    (Longint(Pai386(p)^.op1) <= 3) And
+                                    Not(CS_LittleSize in AktSwitches))
+                                   Then
+                                     Begin
+                                       If Not(TmpBool2) And
+                                         (Longint(Pai386(p)^.op1) = 1)
+                                         Then
+                                           Begin
+                                             Dispose(TmpRef);
+                                             hp1 := new(Pai386,op_reg_reg(A_ADD,Pai386(p)^.Size,
+                                                        TRegister(Pai386(p)^.op2), TRegister(Pai386(p)^.op2)))
+                                           End
+                                         Else hp1 := New(Pai386, op_ref_reg(A_LEA, S_L, TmpRef,
+                                                         TRegister(Pai386(p)^.op2)));
+                                       hp1^.line := p^.line;
+                                       InsertLLItem(p^.last, p^.next, hp1);
+                                       Dispose(p, Done);
+                                       p := hp1;
+                                     End;
+                             End
+                           Else
+                             If (Opt_Processors < PentiumPro) And
+                                (Pai386(p)^.op1t = top_const) And
+                                (Pai386(p)^.op2t = top_reg) Then
+                               If (Longint(Pai386(p)^.op1) = 1)
+                                 Then
+                           {changes "shl $1, %reg" to "add %reg, %reg", which
+                            is the same on a 386, but faster on a 486, and pairable in both U and V
+                            pipes on the Pentium (unlike shl, which is only pairable in the U pipe)}
+                                   Begin
+                                     hp1 := new(Pai386,op_reg_reg(A_ADD,Pai386(p)^.Size,
+                                                TRegister(Pai386(p)^.op2), TRegister(Pai386(p)^.op2)));
+                                     hp1^.line := p^.line;
+                                     InsertLLItem(p^.last, p^.next, hp1);
+                                     Dispose(p, done);
+                                     p := hp1;
+                                   End
+                                 Else If (Pai386(p)^.size = S_L) and
+                                         (Longint(Pai386(p)^.op1) <= 3) Then
+                           {changes "shl $2, %reg" to "lea (,%reg,4), %reg"
+                                    "shl $3, %reg" to "lea (,%reg,8), %reg}
+                                          Begin
+                                            New(TmpRef);
+                                            TmpRef^.segment := R_DEFAULT_SEG;
+                                            TmpRef^.base := R_NO;
+                                            TmpRef^.index := TRegister(Pai386(p)^.op2);
+                                            TmpRef^.scalefactor := PowerOf2(Longint(Pai386(p)^.op1));
+                                            TmpRef^.symbol := nil;
+                                            TmpRef^.isintvalue := false;
+                                            TmpRef^.offset := 0;
+                                            hp1 := new(Pai386,op_ref_reg(A_LEA,S_L,TmpRef, TRegister(Pai386(p)^.op2)));
+                                            hp1^.line := p^.line;
+                                            InsertLLItem(p^.last, p^.next, hp1);
+                                            Dispose(p, done);
+                                            p := hp1;
+                                          End
+                        End;
+                     A_SAR, A_SHR:
+                         {changes the code sequence
+                          shr/sar const1, %reg
+                          shl     const2, %reg
+                          to either "sar/and", "shl/and" or just "and" depending on const1 and const2}
+                       Begin
+                         hp1 := pai(p^.next);
+                         If Assigned(hp1) and
+                            (pai(hp1)^.typ = ait_instruction) and
+                            (Pai386(hp1)^._operator = A_SHL) and
+                            (Pai386(p)^.op1t = top_const) and
+                            (Pai386(hp1)^.op1t = top_const) Then
+                              If (Longint(Pai386(p)^.op1) > Longint(Pai386(hp1)^.op1)) Then
+                                If (Pai386(p)^.op2t = Top_reg) And
+                                   Not(CS_LittleSize In AktSwitches) And
+                                   ((Pai386(p)^.Size = S_B) Or
+                                    (Pai386(p)^.Size = S_L))
+                                    Then
+                                      Begin
+                                        Dec(Longint(Pai386(p)^.op1), Longint(Pai386(hp1)^.op1));
+                                        Pai386(hp1)^._operator := A_And;
+                                        Pai386(hp1)^.op1 := Pointer(PowerOf2(Longint(Pai386(hp1)^.op1))-1);
+                                        If (Pai386(p)^.Size = S_L)
+                                          Then Pai386(hp1)^.op1 := Pointer(Longint(Pai386(hp1)^.op1) Xor $ffffffff)
+                                          Else Pai386(hp1)^.op1 := Pointer(Longint(Pai386(hp1)^.op1) Xor $ff);
+                                      End
+                                    Else
+                                      If (Longint(Pai386(p)^.op1) < Longint(Pai386(hp1)^.op1)) Then
+                                        If (Pai386(p)^.op2t = Top_reg) And
+                                          Not(CS_LittleSize In AktSwitches) And
+                                          ((Pai386(p)^.Size = S_B) Or
+                                           (Pai386(p)^.Size = S_L))
+                                           Then
+                                             Begin
+                                               Dec(Longint(Pai386(hp1)^.op1), Longint(Pai386(p)^.op1));
+                                               Pai386(p)^._operator := A_And;
+                                               Pai386(p)^.op1 := Pointer(PowerOf2(Longint(Pai386(p)^.op1))-1);
+                                               If (Pai386(p)^.Size = S_L)
+                                                 Then Pai386(hp1)^.op1 := Pointer(Longint(Pai386(hp1)^.op1) Xor $ffffffff)
+                                                 Else Pai386(hp1)^.op1 := Pointer(Longint(Pai386(hp1)^.op1) Xor $ff);
+                                             End
+                                           Else
+                                             Begin
+                                               Pai386(p)^._operator := A_And;
+                                               Pai386(p)^.op1 := Pointer(PowerOf2(Longint(Pai386(p)^.op1))-1);
+                                               Case Pai386(p)^.Size Of
+                                                 S_B: Pai386(hp1)^.op1 := Pointer(Longint(Pai386(hp1)^.op1) Xor $ff);
+                                                 S_W: Pai386(hp1)^.op1 := Pointer(Longint(Pai386(hp1)^.op1) Xor $ffff);
+                                                 S_L: Pai386(hp1)^.op1 := Pointer(Longint(Pai386(hp1)^.op1) Xor
+                                                   $ffffffff);
+                                               End;
+                                               AsmL^.remove(hp1);
+                                               dispose(hp1, done);
+                                             End;
+                       End;
+                     A_SUB:
+                       {change "subl $2, %esp; pushw x" to "pushl x"}
+                       Begin
+                         If (Pai386(p)^.op1t = top_const) And
+                            (Longint(Pai386(p)^.op1) = 2) And
+                            (Pai386(p)^.op2t = top_reg) And
+                            (TRegister(Pai386(p)^.op2) = R_ESP)
+                           Then
+                             Begin
+                               hp1 := Pai(p^.next);
+                               While Assigned(hp1) And
+                                     (Pai(hp1)^.typ = ait_instruction) And
+                                     (Pai386(hp1)^._operator <> A_PUSH) Do
+                                 hp1 := Pai(hp1^.next);
+                               If Assigned(hp1) And
+                                  (Pai(hp1)^.typ = ait_instruction) And
+                                  (Pai386(hp1)^._operator = A_PUSH) And
+                                  (Pai386(hp1)^.Size = S_W)
+                                Then
+                                  Begin
+                                    Pai386(hp1)^.size := S_L;
+                                    If (Pai386(hp1)^.op1t = top_reg) Then
+                                      Pai386(hp1)^.op1 := Pointer(Reg16ToReg32(TRegister(Pai386(hp1)^.op1)));
+                                    hp1 := Pai(p^.next);
+                                    AsmL^.Remove(p);
+                                    Dispose(p, Done);
+                                    p := hp1;
+                                    Continue
+                                  End
+                                Else
+                                  If Assigned(p^.last) And
+                                     (Pai(p^.last)^.typ = ait_instruction) And
+                                     (Pai386(p^.last)^._operator = A_SUB) And
+                                     (Pai386(p^.last)^.op1t = top_const) And
+                                     (Pai386(p^.last)^.op2t = top_reg) And
+                                     (TRegister(Pai386(p^.last)^.Op2) = R_ESP)
+                                    Then
+                                      Begin
+                                        hp1 := Pai(p^.last);
+                                        Inc(Longint(Pai386(p)^.op1), Longint(Pai386(hp1)^.op1));
+                                        AsmL^.Remove(hp1);
+                                        Dispose(hp1, Done);
+                                      End;
+                             End;
+                       End;
+                     A_TEST, A_OR:
+                       {removes the line marked with (x) from the sequence
+                        And/or/xor/add/sub/... $x, %y
+                        test/or %y, %y   (x)
+                        j(n)z _Label
+
+                        as the first instruction already adjusts the ZF}
+                        Begin
+                          If (Pai386(p)^.op1 = Pai386(p)^.op2) And
+                             (assigned(p^.last)) And
+                             (pai(p^.last)^.typ = ait_instruction) Then
+                             Case Pai386(p^.last)^._operator Of
+                               A_ADD, A_SUB, A_OR, A_XOR, A_AND, A_SHL, A_SHR:
+                               {There are probably more instructions which can be included}
+                                 Begin
+                                   If (Pai386(p^.last)^.op2 = Pai386(p)^.op1) Then
+                                     Begin
+                                       hp1 := pai(p^.next);
+                                       asml^.remove(p);
+                                       dispose(p, done);
+                                       p := pai(hp1);
+                                       continue
+                                     End;
+                                 End;
+                               A_DEC, A_INC, A_NEG:
+                                 Begin
+                                   If (Pai386(p^.last)^.op1 = Pai386(p)^.op1) Then
+                                     Begin
+                                       hp1 := pai(p^.next);
+                                       asml^.remove(p);
+                                       dispose(p, done);
+                                       p := pai(hp1);
+                                       continue
+                                     End;
+                                 End
+                             End;
+                        End;
+                   End;
+                End
+              Else
+                If (Pai(p)^.typ = ait_label)
+                  Then
+                    If Not(Pai_Label(p)^.l^.is_used)
+                      Then
+                        Begin
+                          hp1 := Pai(p^.next);
+                          AsmL^.Remove(p);
+                          Dispose(p, Done);
+                          p := hp1;
+                          Continue
+                        End;
+         p:=pai(p^.next);
+       end;
+end;
+
+
+  Procedure peepholeopt(AsmL : paasmoutput);
+
+    Procedure FindLoHiLabels;
+    {Walks through the paasmlist to find the lowest and highest label number;
+     Since 0.9.3: also removes unused labels}
+    Var LabelFound: Boolean;
+        P, hp1: Pai;
+    Begin
+      LabelFound := False;
+      LoLab := MaxLongint;
+      HiLab := 0;
+      p := Pai(AsmL^.first);
+      While Assigned(p) Do
+        Begin
+          If (Pai(p)^.typ = ait_label) Then
+            If (Pai_Label(p)^.l^.is_used)
+              Then
+                Begin
+                  LabelFound := True;
+                  If (Pai_Label(p)^.l^.nb < LoLab) Then
+                  LoLab := Pai_Label(p)^.l^.nb;
+                  If (Pai_Label(p)^.l^.nb > HiLab) Then
+                  HiLab := Pai_Label(p)^.l^.nb;
+                End
+              Else
+                Begin
+                  hp1 := pai(p^.next);
+                  AsmL^.Remove(p);
+                  Dispose(p, Done);
+                  p := hp1;
+                  continue;
+                End;
+          p := pai(p^.next);
+        End;
+      If LabelFound
+        Then LabDif := HiLab+1-LoLab
+        Else LabDif := 0;
+    End;
+
+    Procedure BuildLabelTable;
+    {Builds a table with the locations of the labels in the paasmoutput}
+    Var p: Pai;
+    Begin
+      If (LabDif <> 0) Then
+        Begin
+          If (MaxAvail >= LabDif*SizeOf(Pai))
+            Then
+              Begin
+                GetMem(LTable, LabDif*SizeOf(Pai));
+                FillChar(LTable^, LabDif*SizeOf(Pai), 0);
+                p := pai(AsmL^.first);
+                While Assigned(p) Do
+                  Begin
+                    If (Pai(p)^.typ = ait_label) Then
+                      LTable^[Pai_Label(p)^.l^.nb-LoLab] := p;
+                    p := pai(p^.next);
+                  End;
+              End
+            Else LabDif := 0;
+        End;
+    End;
+
+  Begin
+    FindLoHiLabels;
+    BuildLabelTable;
+    DoOptimize(AsmL);
+    DoOptimize(AsmL);
+    If LabDif <> 0 Then Freemem(LTable, LabDif*SizeOf(Pai));
+    ReloadOpt(AsmL)
+  End;
+
+End.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:12  root
+  Initial revision
+
+  Revision 1.29  1998/03/24 21:48:29  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.28  1998/03/19 18:57:05  florian
+    * small fixes applied
+
+  Revision 1.27  1998/03/18 22:50:10  florian
+    + fstp/fld optimization
+    * routines which contains asm aren't longer optimzed
+    * wrong ifdef TEST_FUNCRET corrected
+    * wrong data generation for array[0..n] of char = '01234'; fixed
+    * bug0097 is fixed partial
+    * bug0116 fixed (-Og doesn't use enter of the stack frame is greater than
+      65535)
+
+  Revision 1.26  1998/03/10 23:48:35  florian
+    * a couple of bug fixes to get the compiler with -OGaxz compiler, sadly
+      enough, it doesn't run
+
+  Revision 1.25  1998/03/10 01:17:14  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.24  1998/03/04 19:09:59  jonas
+    * fixed incompatibility with new code generator concerning "mov mem, reg; mov reg, edi" optimization
+
+  Revision 1.23  1998/03/03 22:37:09  peter
+    - uses errors
+
+  Revision 1.22  1998/03/03 14:48:31  jonas
+    * added errors to the uses clause (required for aopt386.inc)
+
+  Revision 1.21  1998/03/02 21:35:15  jonas
+    * added comments from last update
+
+  Revision 1.20  1998/03/02 21:29:04  jonas
+   * change "mov reg, mem; cmp x, mem" to "mov reg, mem; cmp x, reg"
+   * change "and x, reg; jxx" to "test reg, x; jxx" (also allows some extra reloading opts)
+
+
+  Revision 1.19  1998/03/02 01:47:58  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.18  1998/02/27 16:33:26  florian
+    * syntax errors and line too long errors fixed
+
+  Revision 1.17  1998/02/26 17:20:31  jonas
+    * re-enabled mov optimizations, re-commented out the "mov mem, reg1; mov mem, reg2" optimization
+
+  Revision 1.16  1998/02/26 11:56:55  daniel
+  * New assembler optimizations commented out, because of bugs.
+  * Use of dir-/name- and extstr.
+
+  Revision 1.15  1998/02/25 14:08:30  daniel
+  * Compiler uses less memory. *FIX*
+
+  Revision 1.14  1998/02/25 12:32:12  daniel
+  * Compiler uses even less memory.
+
+  Revision 1.13  1998/02/24 21:18:12  jonas
+    * file name back to lower case
+
+  Revision 1.2  1998/02/24 20:32:11  jonas
+    * added comments from latest commit
+
+  Revision 1.1  1998/02/24 20:27:50  jonas
+    + change "cmp $0, reg" to "test reg, reg"
+    + add correct line numbers to Pai386 objects created by the optimizer
+    * dispose TReference of second instructions optimized from "mov mem, reg1; mov
+     mem, reg2" to "mov mem, reg; mov reg1, reg2"
+    + optimize "mov mem, reg1; mov reg1, reg2" to "mov mem, reg2" if reg1 <> esi
+    - disabled changing "mov mem, reg1; mov mem reg2" to "mov mem reg1; mov reg1,
+     reg2" because of conflict with the above optimization
+    + remove second instruction from "mov mem, reg; mov reg, %edi" because edi isn't
+     used anymore afterwards
+    + remove first instruction from "mov %eax, x(%ebp); leave/ret" because it is a
+     write to either a parameter or a temporary function result
+    + change "mov reg1, reg2; mov reg2, mem" to "mov reg1, mem" if reg2 <> esi
+    + change "mov reg1, reg2; test/or reg2, reg2; jxx" to "test/or reg1, reg1" if
+     reg2 <> esi
+    + change "mov reg1, reg2; test/or reg2, reg2" to "mov reg1, reg2; test/or reg1,
+     reg1" to avoid a read/write pnealty if reg2 = esi
+    * took FindLoHiLabel and BuildLabelTable out of the main loop, so they're both
+     called only once per code fragment that has to be optimized
+
+  Revision 1.12  1998/02/19 22:46:55  peter
+    * Fixed linebreaks
+
+  Revision 1.11  1998/02/13 10:34:32  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.10  1998/02/12 17:18:51  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.9  1998/02/12 11:49:39  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.8  1998/02/10 21:57:21  peter
+    + mov [mem1],reg1;mov [mem1],reg2 -> mov [mem1],reg1;mov reg1,reg2
+    + mov const,[mem1];mov [mem1],reg -> mov const,reg;mov reg,[mem1]
+
+  Revision 1.7  1998/02/07 10:10:34  michael
+    + superfluous AND's after MOVZX' removed
+    + change "subl $2, %esp; ... ; pushw x" to "pushl x"
+    + fold "subl $const, %esp; subl $2, %esp" into one instruction
+
+  Revision 1.5  1998/02/02 17:25:43  jonas
+    * back to CVS version; change "lea (reg1), reg2" to "mov reg1, reg2"
+
+
+  Revision 1.2  1997/12/09 13:19:36  carl
+  + renamed pai_labeled --> pai_labeled
+
+  Revision 1.1.1.1  1997/11/27 08:32:50  michael
+  FPC Compiler CVS start
+
+  Pre-CVS log:
+
+  FK   Florian Klampfl (FK)
+  JM   Jonas Maebe
+
+  + feature added
+  - removed
+  * bug fixed or changed
+
+  History (started with version 0.9.0):
+       5th november 1996:
+         * adapted to 0.9.0
+      30th december 1996:
+         * runs with 0.9.1
+      25th July 1996:
+         + removal of superfluous "test %reg, %reg" instructions (JM)
+      28th July 1997:
+         + change "shl $1, %reg" to "add %reg, %reg" (not working) (JM)
+         * fixed bugs in test optimization (tested and working) (JM)
+      29th July 1997:
+         * fixed some pointer bugs in SHL optimization, but it still doesn't
+           work :( (JM)
+      30th July 1997:
+         + change "sar const1, %reg; shl const2, %reg" to one statement (JM)
+         * I finally correctly understand the structure of the pai(386)
+           object <g> and fixed the shl optimization (tested and working) (JM)
+      31th July 1997:
+         + removal of some superfluous reloading of registers (not working) (JM)
+       4th August 1997:
+         * fixed reloading optimization (thanks Florian!) (JM)
+       6th August 1997:
+         + removal of labels which are not referenced by any instruction
+           (allows for easier and better optimization), but it is slow :( (JM)
+       8th August 1997:
+         - removed label-removal procedure as it seems to be impossible to
+           find out if there are labels which are referenced through a jump
+           table (JM)
+      15th August 1997:
+         + removal of superfluous "or %reg, %reg" instructions (JM)
+      22th september 1997:
+         * test is also removed if it follows neg, shl and shr (FK)
+         - removed the sar/shl optimization because:
+             movl $0xff,%eax
+             shrl $0x3,%eax
+             shll $0x3,%eax
+
+               => EAX is $0xf8  !!!   (FK)
+      23th September 1997:
+         + function FindLabel() so sequences like "jmp l2;l1:;l2:" can be
+           optimized (JM)
+      24th September 1997:
+         + successive jumps reduced to one jump (see explanation at
+           GetFinalDestination). Works fine, but seems to enlarge the code...
+           I suppose because there are more >128 bytes-jumps and their opcodes
+           are longer. If (cs_littlesize in aktwitches^), this optimization is
+           not performed (JM)
+      26th September 1997:
+         * removed the "Var" in front of the parameters of InsertLLItem, which
+           had introduced the need for the temp var p1 (also removed) (JM)
+         * fixed a bug in FindLabel() that caused false positives in some
+           cases (JM)
+         * removed the unit systems from the uses clause because it isn't
+           needed anymore (it was needed for the label-removal procedure) (JM)
+         * adapted for 0.9.3 and 0.9.4 (still bugged) (JM)
+      27th September 1997:
+         * fixed 0.9.3+ related bugs (JM)
+         * make peepholeopt optimize the code twice, because after the first
+           pass several labels can be removed (those unset by
+           GetFinalDestination) which sometimes allows extra optimizations
+           (not when (cs_littlesize in aktswitches^), because then
+           GetFinalDestination is never called)) (JM)
+       1st October 1997:
+         * adapted to use with tp (tlabeltable too large and lines to long) (FK)
+         + removal of dead code (which sits between a jmp and the next label), also
+           sometimes allows some extra optimizations during the second pass (JM)
+       2nd October 1997:
+         + successive conditional jumps reduced to one jump (JM)
+        3rd October 1997:
+         * made FindLabel a little shorter&faster (JM)
+         * make peepholeopt always go through the code twice, because the dead
+           code removal can allow some extra optimizations (JM)
+       10th October 1997:
+         * optimized remove_mov code a little (JM)
+       12th October 1997:
+         * bugfixed remove_mov change (JM)
+       20th October 1997:
+         * changed the combiTmpBoolnation of two adds (which replaced "shl 2, %reg")
+           to a "lea %reg, (,%reg,4)" if the register is 32 bit (JM)
+       21th October 1997:
+         + change movzx to faster equivalents (not working) (thanks to Daniel
+           Mantoine for the initial idea) (JM)
+       30th October 1997:
+         * found out that "shl $const, %reg" is a pairable instruction after
+           all and therefore removed the dual "add %reg, %reg" sequences (JM)
+         * replace "shl $3, %reg" with "lea %reg, (,%reg,8)" (JM)
+        2nd November 1997:
+         * fixed movzx replacements (JM)
+        3rd November 1997:
+         * some changes in the optimization logic to generate better PPro
+           code (JM)
+         * change two consecutive 16 bit immediatie pushes to one 32 bit push
+           (thanks to Synopsis for the suggestion) (JM)
+        4th November 1997:
+         + replace some constant multiplies with lea sequences (suggestion from
+           Synopsis, Daniel Mantoine and Florian Klaempfl) (JM)
+        5th November 1997:
+         * finally bugfixed sar/shl optimization and reactivated it (JM)
+         + some extra movzx optimizations (JM)
+        6th November 1997:
+         + change shl/add/sub sequences to one lea instruction if possible (JM)
+         * bugfixed some imul replacements (JM)
+       30th November 1997:
+         * merge two consecutive "and $const, %reg"'s to one statement (JM)
+        5th December 1997:
+         + change "mov $0, %reg" to "xor %reg, %reg" (JM)
+         * adapted to TP (typecasted pointer to longint for comparisons
+           and one line too long) (JM)
+}
+

compiler/asmutils.pas

@@ -0,0 +1,1697 @@
+{
+    $Id$
+    Copyright (c) 1998 Carl Eric Codere
+
+    This unit implements some support routines for assembler parsing
+
+    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 AsmUtils;
+
+{*************************************************************************}
+{  This unit implements some objects as well as utilities which will be   }
+{  used by all inline assembler parsers (non-processor specific).         }
+{                                                                         }
+{  Main routines/objects herein:                                          }
+{  o Object TExprParse is a simple expression parser to resolve assembler }
+{    expressions. (Based generally on some code by Thai Tran from SWAG).  }
+{  o Object TInstruction is a simple object used for instructions         }
+{  o Record TOperand is a simple record used to store information on      }
+{    each operand.                                                        }
+{  o String conversion routines from octal,binary and hex to decimal.     }
+{  o A linked list object/record for local labels                         }
+{  o Routines for retrieving symbols (local and global)                   }
+{  o Object for a linked list of strings (with duplicate strings not      }
+{    allowed).                                                            }
+{  o Non-processor dependant routines for adding instructions to the      }
+{    instruction list.                                                    }
+{*************************************************************************}
+
+
+{--------------------------------------------------------------------}
+{ LEFT TO DO:                                                        }
+{ o Fix the remaining bugs in the expression parser, such as with    }
+{     4+-3                                                           }
+{ o Add support for local typed constants search.                    }
+{ o Add support for private/protected fields in method assembler     }
+{    routines.                                                       }
+{--------------------------------------------------------------------}
+Interface
+
+Uses
+  symtable,aasm,hcodegen,verbose,systems,globals,files,strings,
+  cobjects,
+{$ifdef i386}
+  i386;
+{$endif}
+{$ifdef m68k}
+   m68k;
+{$endif}
+
+
+Const
+  RPNMax = 10;             { I think you only need 4, but just to be safe }
+  OpMax  = 25;
+
+  maxoperands = 3;         { Maximum operands for assembler instructions }
+
+
+Type
+
+
+  {---------------------------------------------------------------------}
+  {                     Label Management types                          }
+  {---------------------------------------------------------------------}
+
+
+    PAsmLabel = ^TAsmLabel;
+    PString = ^String;
+
+    { Each local label has this structure associated with it }
+    TAsmLabel = record
+      name: PString;    { pointer to a pascal string name of label }
+      lab: PLabel;      { pointer to a label as defined in FPC     }
+      emitted: boolean; { as the label itself been emitted ?       }
+      next: PAsmLabel;  { next node                                }
+    end;
+
+    TAsmLabelList = Object
+    public
+      First: PAsmLabel;
+      Constructor Init;
+      Destructor Done;
+      Procedure Insert(s:string; lab: PLabel; emitted: boolean);
+      Function Search(const s: string): PAsmLabel;
+    private
+      Last: PAsmLabel;
+      Function NewPasStr(s:string): PString;
+    end;
+
+
+
+  {---------------------------------------------------------------------}
+  {                 Instruction management types                        }
+  {---------------------------------------------------------------------}
+
+  toperandtype = (OPR_NONE,OPR_REFERENCE,OPR_CONSTANT,OPR_REGISTER,OPR_LABINSTR,
+                  OPR_REGLIST);
+
+    { When the TReference field isintvalue = TRUE }
+    { then offset points to an ABSOLUTE address   }
+    { otherwise isintvalue should always be false }
+
+    { Special cases:                              }
+    {   For the M68k Target, size is UNUSED, the  }
+    {   opcode determines the size of the         }
+    {   instruction.                              }
+    {  DIVS/DIVU/MULS/MULU of the form dn,dn:dn   }
+    {  is stored as three operands!!              }
+
+
+    { Each instruction operand can be of this type }
+    TOperand = record
+      size: topsize;
+      opinfo: longint; { ao_xxxx flags }
+      case operandtype:toperandtype of
+       { the size of the opr_none field should be at least equal to each }
+       { other field as to facilitate initialization.                    }
+       OPR_NONE: (l: array[1..sizeof(treference)] of byte);
+       OPR_REFERENCE: (ref:treference);
+       OPR_CONSTANT:  (val: longint);
+       OPR_REGISTER:  (reg:tregister);
+       OPR_LABINSTR: (hl: plabel);
+       { Register list such as in the movem instruction }
+       OPR_REGLIST:  (list: set of tregister);
+    end;
+
+
+
+    TInstruction = object
+    public
+      operands: array[1..maxoperands] of TOperand;
+      { if numops = zero, a size may still be valid in operands[1] }
+      { it still should be checked.                                }
+      numops: byte;
+      { set to TRUE if the instruction is labeled.                }
+      labeled: boolean;
+      { This is used for instructions such A_CMPSB... etc, to determine }
+      { the size of the instruction.                                    }
+      stropsize: topsize;
+      procedure init;
+      { sets up the prefix field with the instruction pointed to in s }
+      procedure addprefix(tok: tasmop);
+      { sets up the instruction with the instruction pointed to in s }
+      procedure addinstr(tok: tasmop);
+      { get the current instruction of this object }
+      function getinstruction: tasmop;
+      { get the current prefix of this instruction }
+      function getprefix: tasmop;
+    private
+      prefix: tasmop;
+      instruction: tasmop;
+    end;
+
+
+
+
+  {---------------------------------------------------------------------}
+  {                   Expression parser types                           }
+  {---------------------------------------------------------------------}
+
+  { expression parser error codes }
+  texpr_error =
+  (zero_divide,       { divide by zero.     }
+   stack_overflow,    { stack overflow.     }
+   stack_underflow,   { stack underflow.    }
+   invalid_number,    { invalid conversion  }
+   invalid_op);       { invalid operator    }
+
+
+   TExprOperator = record
+    ch: char;           { operator }
+    is_prefix: boolean; { was it a prefix, possible prefixes are +,- and not }
+   end;
+
+  String15 = String[15];
+  {**********************************************************************}
+  { The following operators are supported:                              }
+  {  '+' : addition                                                     }
+  {  '-' : subtraction                                                  }
+  {  '*' : multiplication                                               }
+  {  '/' : modulo division                                              }
+  {  '^' : exclusive or                                                 }
+  {  '<' : shift left                                                   }
+  {  '>' : shift right                                                  }
+  {  '&' : bitwise and                                                  }
+  {  '|' : bitwise or                                                   }
+  {  '~' : bitwise complement                                           }
+  {  '%' : modulo division                                              }
+  {  nnn: longint numbers                                               }
+  {  ( and ) parenthesis                                                }
+  {**********************************************************************}
+
+  TExprParse = Object
+    public
+     Constructor Init;
+     Destructor Done;
+     Function Evaluate(Expr:  String): longint;
+     Procedure Error(anerror: texpr_error); virtual;
+     Function Priority(_Operator: Char): Integer; virtual;
+    private
+     RPNStack   : Array[1..RPNMax] of longint;        { Stack For RPN calculator }
+     RPNTop     : Integer;
+     OpStack    : Array[1..OpMax] of TExprOperator;    { Operator stack For conversion }
+     OpTop      : Integer;
+     Procedure RPNPush(Num: Longint);
+     Function RPNPop: Longint;
+     Procedure RPNCalc(token: String15; prefix: boolean);
+     Procedure OpPush(_Operator: char; prefix: boolean);
+     { In reality returns TExprOperaotr }
+     Procedure OpPop(var _Operator:TExprOperator);
+  end;
+
+
+  {---------------------------------------------------------------------}
+  {                     String routines                                 }
+  {---------------------------------------------------------------------}
+
+
+  {*********************************************************************}
+  { PROCEDURE PadZero;                                                  }
+  {  Description: Makes sure that the string specified is of the given  }
+  {  length, by padding it with binary zeros, or truncating if necessary}
+  {  Remark: The return value is determined BEFORE any eventual padding.}
+  {  Return Value: TRUE  = if length of string s was <= then n          }
+  {                FALSE = if length of string s was > then n           }
+  {*********************************************************************}
+  Function PadZero(Var s: String; n: byte): Boolean;
+
+  { Converts an Hex digit string to a Decimal string                      }
+  { Returns '' if there was an error.                                     }
+  Function HexToDec(const S:String): String;
+
+  { Converts a binary digit string to a Decimal string                    }
+  { Returns '' if there was an error.                                     }
+  Function BinaryToDec(const S:String): String;
+
+  { Converts an octal digit string to a Decimal string                    }
+  { Returns '' if there was an error.                                     }
+  Function OctalToDec(const S:String): String;
+
+  { Converts a string containing C styled escape sequences to }
+  { a pascal style string.                                    }
+  Function EscapeToPascal(const s:string): string;
+
+  Procedure ConcatPasString(p : paasmoutput;s:string);
+  { Writes the string s directly to the assembler output }
+  Procedure ConcatDirect(p : paasmoutput;s:string);
+
+
+  {---------------------------------------------------------------------}
+  {                     Symbol helper routines                          }
+  {---------------------------------------------------------------------}
+
+  Function GetTypeOffset(const base: string; const field: string;
+    Var Offset: longint):boolean;
+  Function GetVarOffset(const base: string; const field: string;
+    Var Offset: longint):boolean;
+  Function SearchIConstant(const s:string; var l:longint): boolean;
+  Function SearchLabel(const s: string; var hl: plabel): boolean;
+  Function CreateVarInstr(var Instr: TInstruction; const hs:string;
+     operandnum:byte):boolean;
+  {*********************************************************************}
+  { FUNCTION NewPasStr(s:string): PString                               }
+  {  Description: This routine allocates a string on the heap and       }
+  {  returns a pointer to the allocated string.                         }
+  {                                                                     }
+  {  Remarks: The string allocated should not be modified, since it's   }
+  {  length will be less then 255.                                      }
+  {  Remarks: It is assumed that HeapError will be called if an         }
+  {  allocation fails.                                                  }
+  {*********************************************************************}
+  Function newpasstr(s: string): Pointer;
+  Procedure SetupResult(Var Instr:TInstruction; operandnum: byte);
+  Procedure FWaitWarning;
+
+  {---------------------------------------------------------------------}
+  {                  Instruction generation routines                    }
+  {---------------------------------------------------------------------}
+
+  { swaps in the case of a 2/3 operand opcode the destination and the    }
+  { source as to put it in AT&T style instruction format.                }
+  Procedure SwapOperands(Var instr: TInstruction);
+  Procedure ConcatLabel(p : paasmoutput;op : tasmop;var l : plabel);
+  Procedure ConcatConstant(p : paasmoutput;value: longint; maxvalue: longint);
+  Procedure ConcatRealConstant(p : paasmoutput;value: bestreal; real_typ : tfloattype);
+  Procedure ConcatString(p : paasmoutput;s:string);
+  Procedure ConcatPublic(p:paasmoutput;const s : string);
+  Procedure ConcatLocal(p:paasmoutput;const s : string);
+  Procedure ConcatGlobalBss(const s : string;size : longint);
+  Procedure ConcatLocalBss(const s : string;size : longint);
+  { add to list of external labels }
+  Procedure ConcatExternal(const s : string;typ : texternal_typ);
+  { add to internal list of labels }
+  Procedure ConcatInternal(const s : string;typ : texternal_typ);
+
+Implementation
+
+{*************************************************************************}
+{                         Expression Parser                               }
+{*************************************************************************}
+
+Constructor TExprParse.Init;
+Begin
+end;
+
+Procedure TExprParse.Error(anerror:texpr_error);
+var
+  t : tmsgconst;
+Begin
+  case anerror of
+  zero_divide: t:=assem_f_ev_zero_divide;
+  stack_overflow: t:=assem_f_ev_stack_overflow;
+  stack_underflow: t:=assem_f_ev_stack_underflow;
+  invalid_number: t:=assem_f_ev_invalid_number;
+  invalid_op: t:=assem_f_ev_invalid_op;
+  else
+   t:=assem_f_ev_unknown;
+  end;
+  Message(t);
+end;
+
+Procedure TExprParse.RPNPush(Num : longint); { Add an operand to the top of the RPN stack }
+begin
+  if RPNTop < RPNMax then
+  begin
+    Inc(RPNTop);
+    RPNStack[RPNTop] := Num;
+  end
+  else
+    Error(stack_overflow); { Put some error handler here }
+end;
+
+
+
+
+Function TExprParse.RPNPop : longint;       { Get the operand at the top of the RPN stack }
+begin
+  if RPNTop > 0 then
+  begin
+    RPNPop := RPNStack[RPNTop];
+    Dec(RPNTop);
+  end
+  else  { Put some error handler here }
+   Error(stack_underflow);
+end;
+
+Procedure TExprParse.RPNCalc(Token : String15; prefix:boolean);                       { RPN Calculator }
+Var
+  Temp  : longint;
+  LocalError : Integer;
+begin
+{  Write(Token, ' ');              This just outputs the RPN expression }
+
+  if (Length(Token) = 1) and (Token[1] in ['+', '-', '*', '/','&','|','%','^','~','<','>']) then
+  Case Token[1] of                                   { Handle operators }
+    '+' : Begin
+       if prefix then
+       else
+          RPNPush(RPNPop + RPNPop);
+     end;
+    '-' : Begin
+      if prefix then
+         RPNPush(-(RPNPop))
+      else
+         RPNPush(RPNPop - RPNPop);
+     end;
+    '*' : RPNPush(RPNPop * RPNPop);
+    '&' : RPNPush(RPNPop AND RPNPop);
+    '|' : RPNPush(RPNPop OR RPNPop);
+    '~' : RPNPush(NOT RPNPop);
+    '<' : RPNPush(RPNPop SHL RPNPop);
+    '>' : RPNPush(RPNPop SHR RPNPop);
+    '%' : begin
+      Temp := RPNPop;
+      if Temp <> 0 then
+       RPNPush(RPNPop mod Temp)
+      else Error(zero_divide); { Handle divide by zero error }
+     end;
+    '^' : RPNPush(RPNPop XOR RPNPop);
+    '/' :
+    begin
+      Temp := RPNPop;
+      if Temp <> 0 then
+   RPNPush(RPNPop div Temp)
+      else  Error(zero_divide);{ Handle divide by 0 error }
+    end;
+  end
+  else
+  begin                   { Convert String to number and add to stack }
+    if token='-2147483648' then
+      begin
+         temp:=$80000000;
+         localerror:=0;
+      end
+    else
+      Val(Token, Temp, LocalError);
+    if LocalError = 0 then
+      RPNPush(Temp)
+    else  Error(invalid_number);{ Handle error }
+  end;
+end;
+
+Procedure TExprParse.OpPush(_Operator : char;prefix: boolean);  { Add an operator onto top of the stack }
+begin
+  if OpTop < OpMax then
+  begin
+    Inc(OpTop);
+    OpStack[OpTop].ch := _Operator;
+    OpStack[OpTop].is_prefix := prefix;
+  end
+  else Error(stack_overflow); { Put some error handler here }
+end;
+
+Procedure TExprParse.OpPop(var _Operator:TExprOperator);               { Get operator at the top of the stack }
+begin
+  if OpTop > 0 then
+  begin
+    _Operator := OpStack[OpTop];
+    Dec(OpTop);
+  end
+  else Error(stack_underflow); { Put some error handler here }
+end;
+
+Function TExprParse.Priority(_Operator : Char) : Integer; { Return priority of operator }
+{ The greater the priority, the higher the precedence }
+begin
+  Case _Operator OF
+    '('      : Priority := 0;
+    '+', '-' : Priority := 1;
+    '*', '/','%','<','>' : Priority := 2;
+    '|','&','^','~': Priority := 0;
+    else  Error(invalid_op);{ More error handling }
+  end;
+end;
+
+Function TExprParse.Evaluate(Expr : String):longint;
+Var
+  I     : Integer;
+  Token : String15;
+  opr: TExprOperator;
+begin
+  OpTop  := 0;                                              { Reset stacks }
+  RPNTop := 0;
+  Token  := '';
+
+  For I := 1 to Length(Expr) DO
+
+     if Expr[I] in ['0'..'9'] then
+      begin       { Build multi-digit numbers }
+   Token := Token + Expr[I];
+   if I = Length(Expr) then          { Send last one to calculator }
+      RPNCalc(Token,false);
+      end
+     else
+     if Expr[I] in ['+', '-', '*', '/', '(', ')','^','&','|','%','~','<','>'] then
+      begin
+       if Token <> '' then
+   begin        { Send last built number to calc. }
+    RPNCalc(Token,false);
+    Token := '';
+   end;
+
+     Case Expr[I] OF
+       '(' : OpPush('(',false);
+       ')' :
+     begin
+        While OpStack[OpTop].ch <> '(' DO
+        Begin
+          OpPop(opr);
+          RPNCalc(opr.ch,opr.is_prefix);
+        end;
+        OpPop(opr);                          { Pop off and ignore the '(' }
+     end;
+
+   '+','-','~':  Begin
+      While (OpTop > 0) AND
+          (Priority(Expr[I]) <= Priority(OpStack[OpTop].ch)) DO
+        Begin
+             OpPop(opr);
+             RPNCalc(opr.ch,opr.is_prefix);
+        end;
+       { if start of expression then surely a prefix }
+       { or if previous char was also an operator    }
+       { push it and don't evaluate normally         }
+       { workaround for -2147483648 }
+       if (expr[I]='-') and (expr[i+1] in ['0'..'9']) then
+         begin
+            token:='-';
+            expr[i]:='+';
+         end;
+       if (I = 1) or (not (Expr[I-1] in ['0'..'9','(',')'])) then
+         OpPush(Expr[I],true)
+       else
+         OpPush(Expr[I],false);
+      end;
+
+      '*', '/','^','|','&','%','<','>' :
+    begin
+      While (OpTop > 0) AND
+          (Priority(Expr[I]) <= Priority(OpStack[OpTop].ch)) DO
+        Begin
+             OpPop(opr);
+             RPNCalc(opr.ch,opr.is_prefix);
+        end;
+        OpPush(Expr[I],false);
+    end;
+     end; { Case }
+  end
+    else Error(invalid_op);
+      { Handle bad input error }
+
+  While OpTop > 0 do                     { Pop off the remaining operators }
+  Begin
+    OpPop(opr);
+    RPNCalc(opr.ch,opr.is_prefix);
+  end;
+
+  { The result is stored on the top of the stack }
+  Evaluate := RPNPop;
+end;
+
+
+Destructor TExprParse.Done;
+Begin
+end;
+
+
+{*************************************************************************}
+{                         String conversions/utils                        }
+{*************************************************************************}
+
+  Function newpasstr(s: string): Pointer;
+  Var
+   StrPtr: PString;
+  Begin
+    GetMem(StrPtr, length(s)+1);
+    Move(s,StrPtr^,length(s)+1);
+    newpasstr:= Strptr;
+  end;
+
+
+  Function EscapeToPascal(const s:string): string;
+  { converts a C styled string - which contains escape }
+  { characters to a pascal style string.               }
+  var
+   i,j: word;
+   str: string;
+   temp: string;
+   value: byte;
+   code: integer;
+  Begin
+   str:='';
+   i:=1;
+   j:=1;
+   repeat
+     if s[i] = '\' then
+     Begin
+      Inc(i);
+      if i > 255 then
+      Begin
+       EscapeToPascal:=str;
+       exit;
+      end;
+      case s[i] of
+       '\': insert('\',str,j);
+       'b': insert(#08,str,j);
+       'f': insert(#12,str,j);
+       'n': insert(#10,str,j);
+       'r': insert(#13,str,j);
+       't': insert(#09,str,j);
+       '"': insert('"',str,j);
+       { octal number }
+       '0'..'7': Begin
+                  temp:=s[i];
+                  temp:=temp+s[i+1];
+                  temp:=temp+s[i+2];
+                  inc(i,2);
+                  val(octaltodec(temp),value,code);
+                  if (code <> 0) then
+                   Message(assem_w_invalid_numeric);
+                  insert(chr(value),str,j);
+                 end;
+     { hexadecimal number }
+     'x': Begin
+            temp:=s[i+1];
+            temp:=temp+s[i+2];
+            inc(i,2);
+            val(hextodec(temp),value,code);
+            if (code <> 0) then
+             Message(assem_w_invalid_numeric);
+            insert(chr(value),str,j);
+          end;
+     else
+      Begin
+         Message1(assem_e_escape_seq_ignored,s[i]);
+         insert(s[i],str,j);
+      end;
+    end; {end case }
+    Inc(i);
+   end
+   else
+   Begin
+    Insert(s[i],str,j);
+    Inc(i);
+    if i > 255 then
+    Begin
+     EscapeToPascal:=str;
+     exit;
+    end;
+   end;
+   Inc(j);
+ until (i > length(s)) or (j > 255);
+ EscapeToPascal:=str;
+end;
+
+
+
+  Function OctalToDec(const S:String): String;
+  { Converts an octal string to a Decimal string }
+  { Returns '' if there was an error.            }
+  var vs: longint;
+    c: byte;
+    st: string;
+  Begin
+   vs := 0;
+   for c:=1 to length(s) do
+   begin
+     case s[c] of
+     '0': vs:=vs shl 3;
+     '1': vs:=vs shl 3+1;
+     '2': vs:=vs shl 3+2;
+     '3': vs:=vs shl 3+3;
+     '4': vs:=vs shl 3+4;
+     '5': vs:=vs shl 3+5;
+     '6': vs:=vs shl 3+6;
+     '7': vs:=vs shl 3+7;
+    else
+      begin
+        OctalToDec := '';
+        exit;
+      end;
+    end;
+   end;
+     str(vs,st);
+     OctalToDec := st;
+  end;
+
+  Function BinaryToDec(const S:String): String;
+  { Converts a binary string to a Decimal string }
+  { Returns '' if there was an error.            }
+  var vs: longint;
+    c: byte;
+    st: string;
+  Begin
+   vs := 0;
+   for c:=1 to length(s) do
+   begin
+     if s[c] = '0' then
+       vs:=vs shl 1
+     else
+     if s[c]='1' then
+       vs:=vs shl 1+1
+     else
+       begin
+         BinaryToDec := '';
+         exit;
+       end;
+   end;
+     str(vs,st);
+     BinaryToDec := st;
+  end;
+
+
+  Function HexToDec(const S:String): String;
+  var vs: longint;
+    c: byte;
+    st: string;
+  Begin
+   vs := 0;
+   for c:=1 to length(s) do
+   begin
+     case upcase(s[c]) of
+     '0': vs:=vs shl 4;
+     '1': vs:=vs shl 4+1;
+     '2': vs:=vs shl 4+2;
+     '3': vs:=vs shl 4+3;
+     '4': vs:=vs shl 4+4;
+     '5': vs:=vs shl 4+5;
+     '6': vs:=vs shl 4+6;
+     '7': vs:=vs shl 4+7;
+     '8': vs:=vs shl 4+8;
+     '9': vs:=vs shl 4+9;
+     'A': vs:=vs shl 4+10;
+     'B': vs:=vs shl 4+11;
+     'C': vs:=vs shl 4+12;
+     'D': vs:=vs shl 4+13;
+     'E': vs:=vs shl 4+14;
+     'F': vs:=vs shl 4+15;
+    else
+      begin
+        HexToDec := '';
+        exit;
+      end;
+    end;
+   end;
+     str(vs,st);
+     HexToDec := st;
+  end;
+
+  Function PadZero(Var s: String; n: byte): Boolean;
+  Begin
+    PadZero := TRUE;
+    { Do some error checking first }
+    if Length(s) = n then
+      exit
+    else
+    if Length(s) > n then
+    Begin
+      PadZero := FALSE;
+      delete(s,n+1,length(s));
+      exit;
+    end
+    else
+      PadZero := TRUE;
+    { Fill it up with the specified character }
+    fillchar(s[length(s)+1],n-1,#0);
+    s[0] := chr(n);
+  end;
+
+{*************************************************************************}
+{                          Instruction utilities                          }
+{*************************************************************************}
+
+ Procedure TInstruction.init;
+ var
+  k: integer;
+ Begin
+  numops := 0;
+  labeled := FALSE;
+  stropsize := S_NO;
+  prefix := A_NONE;
+  instruction := A_NONE;
+  for k:=1 to maxoperands do
+  begin
+    operands[k].size := S_NO;
+    operands[k].operandtype := OPR_NONE;
+    { init to zeros }
+    fillchar(operands[k].l, sizeof(operands[k].l),#0);
+  end;
+ end;
+
+ Procedure TInstruction.addprefix(tok: tasmop);
+ Begin
+   if tok = A_NONE then
+    Message(assem_e_syn_prefix_not_found);
+   if Prefix = A_NONE then
+    Prefix := tok
+   else
+    Message(assem_e_syn_try_add_more_prefix);
+ end;
+
+ Procedure TInstruction.addinstr(tok: tasmop);
+ Begin
+   if tok = A_NONE then
+    Message(assem_e_syn_opcode_not_found);
+   Instruction := tok;
+ end;
+
+ function TInstruction.getinstruction: tasmop;
+ Begin
+   getinstruction := Instruction;
+ end;
+      { get the current prefix of this instruction }
+ function TInstruction.getprefix: tasmop;
+ Begin
+   getprefix := prefix;
+ end;
+
+{*************************************************************************}
+{                          Local label utilities                          }
+{*************************************************************************}
+
+  Constructor TAsmLabelList.Init;
+  Begin
+    First := nil;
+    Last := nil;
+  end;
+
+
+  Procedure TAsmLabelList.Insert(s:string; lab: PLabel; emitted: boolean);
+  {*********************************************************************}
+  {  Description: Insert a node at the end of the list with lab and     }
+  {  and the name in s. The name is allocated on the heap.              }
+  {  Duplicates are not allowed.                                        }
+  {  Indicate in emitted if this label itself has been emitted, or is it}
+  {  a simple labeled instruction?                                      }
+  {*********************************************************************}
+  Begin
+    if search(s) = nil then
+    Begin
+      if First = nil then
+       Begin
+          New(First);
+          Last := First;
+       end
+      else
+       Begin
+          New(Last^.Next);
+          Last := Last^.Next;
+       end;
+      Last^.name := NewPasStr(s);
+      Last^.Lab := lab;
+      Last^.Next := nil;
+      Last^.emitted := emitted;
+    end;
+  end;
+
+
+
+  Function TAsmLabelList.Search(const s: string): PAsmLabel;
+  {*********************************************************************}
+  {  Description: This routine searches for a label named s in the      }
+  {  linked list, returns a pointer to the label if found, otherwise    }
+  {  returns nil.                                                       }
+  {*********************************************************************}
+  Var
+    asmlab: PAsmLabel;
+  Begin
+    asmlab := First;
+    if First = nil then
+    Begin
+      Search := nil;
+      exit;
+    end;
+    While (asmlab^.name^ <> s) and (asmlab^.Next <> nil) do
+       asmlab := asmlab^.Next;
+    if asmlab^.name^ = s then
+       search := asmlab
+    else
+       search := nil;
+  end;
+
+
+  Destructor TAsmLabelList.Done;
+  {*********************************************************************}
+  {  Description: This routine takes care of deallocating all nodes     }
+  {  in the linked list, as well as deallocating the string pointers    }
+  {  of these nodes.                                                    }
+  {                                                                     }
+  {  Remark: The PLabel field is NOT freed, the compiler takes care of  }
+  {  this.                                                              }
+  {*********************************************************************}
+  Var
+    temp: PAsmLabel;
+    temp1: PAsmLabel;
+  Begin
+    temp := First;
+    while temp <> nil do
+    Begin
+      Freemem(Temp^.name, length(Temp^.name^)+1);
+      Temp1 := Temp^.Next;
+      Dispose(Temp);
+      Temp := Temp1;
+      { The plabel could be deleted here, but let us not do }
+      { it, FPC will do it instead.                         }
+    end;
+  end;
+
+
+
+  Function TAsmLabelList.newpasstr(s: string): PString;
+  {*********************************************************************}
+  { FUNCTION NewPasStr(s:string): PString                               }
+  {  Description: This routine allocates a string on the heap and       }
+  {  returns a pointer to the allocated string.                         }
+  {                                                                     }
+  {  Remarks: The string allocated should not be modified, since it's   }
+  {  length will be less then 255.                                      }
+  {  Remarks: It is assumed that HeapError will be called if an         }
+  {  allocation fails.                                                  }
+  {*********************************************************************}
+  Var
+   StrPtr: PString;
+  Begin
+    GetMem(StrPtr, length(s)+1);
+    Move(s,StrPtr^,length(s)+1);
+    newpasstr:= Strptr;
+  end;
+
+{*************************************************************************}
+{                      Symbol table helper routines                       }
+{*************************************************************************}
+
+
+  Procedure SwapOperands(Var instr: TInstruction);
+  Var
+   tempopr: TOperand;
+  Begin
+    if instr.numops = 2 then
+    Begin
+      tempopr := instr.operands[1];
+      instr.operands[1] := instr.operands[2];
+      instr.operands[2] := tempopr;
+    end
+    else
+    if instr.numops = 3 then
+    Begin
+      tempopr := instr.operands[1];
+      instr.operands[1] := instr.operands[3];
+      instr.operands[3] := tempopr;
+    end;
+  end;
+
+
+  Function SearchIConstant(const s:string; var l:longint): boolean;
+  {**********************************************************************}
+  {  Description: Searches for a CONSTANT of name s in either the local  }
+  {  symbol list, then in the global symbol list, and returns the value  }
+  {  of that constant in l. Returns TRUE if successfull, if not found,   }
+  {  or if the constant is not of correct type, then returns FALSE       }
+  { Remarks: Also handle TRUE and FALSE returning in those cases 1 and 0 }
+  {  respectively.                                                       }
+  {**********************************************************************}
+  var
+    sym: psym;
+  Begin
+    SearchIConstant := FALSE;
+    { check for TRUE or FALSE reserved words first }
+    if s = 'TRUE' then
+    Begin
+       SearchIConstant := TRUE;
+       l := 1;
+    end
+    else
+    if s = 'FALSE' then
+    Begin
+       SearchIConstant := TRUE;
+       l := 0;
+    end
+    else
+    if assigned(aktprocsym) then
+    Begin
+      if assigned(aktprocsym^.definition) then
+      Begin
+   { Check the local constants }
+    if assigned(aktprocsym^.definition^.localst) then
+       sym := aktprocsym^.definition^.localst^.search(s)
+    else
+       sym := nil;
+    if assigned(sym) then
+    Begin
+       if (sym^.typ = constsym) and (pconstsym(sym)^.consttype in
+         [constord,constint,constchar,constbool]) then
+       Begin
+          l:=pconstsym(sym)^.value;
+          SearchIConstant := TRUE;
+          exit;
+       end;
+    end;
+      end;
+    end;
+    { Check the global constants }
+    getsym(s,false);
+    if srsym <> nil then
+    Begin
+      if (srsym^.typ=constsym) and (pconstsym(srsym)^.consttype in
+       [constord,constint,constchar,constbool]) then
+      Begin
+        l:=pconstsym(srsym)^.value;
+        SearchIConstant := TRUE;
+        exit;
+      end;
+    end;
+  end;
+
+
+  Procedure SetupResult(Var Instr:TInstruction; operandnum: byte);
+  {**********************************************************************}
+  {  Description: This routine changes the correct fields and correct    }
+  {  offset in the reference, so that it points to the __RESULT or       }
+  {  @Result variable (depending on the inline asm).                     }
+  {  Resturns a reference with all correct offset correctly set up.      }
+  {  The Operand should already point to a treference on entry.          }
+  {**********************************************************************}
+  Begin
+    { replace by correct offset. }
+    if assigned(procinfo.retdef) and
+      (procinfo.retdef<>pdef(voiddef)) then
+    begin
+      instr.operands[operandnum].ref.offset := procinfo.retoffset;
+      instr.operands[operandnum].ref.base :=  procinfo.framepointer;
+      { always assume that the result is valid. }
+      procinfo.funcret_is_valid:=true;
+    end
+    else
+     Message(assem_e_invalid_symbol_ref);
+  end;
+
+
+  Procedure FWaitWarning;
+  begin
+    if (target_info.target=target_GO32V2) and (cs_fp_emulation in aktswitches) then
+     Message(assem_w_fwait_emu_prob);
+  end;
+
+
+
+
+  Function GetVarOffset(const base: string; const field: string;
+    Var Offset: longint):boolean;
+  { search and returns the offset of records/objects of the base }
+  { with field name setup in field.                              }
+  { returns 0 if not found.                                      }
+  { used when base is a variable or a typed constant name.       }
+   var
+    sym:psym;
+    p: psym;
+  Begin
+     GetVarOffset := FALSE;
+     Offset := 0;
+     { local list }
+     if assigned(aktprocsym) then
+     begin
+      if assigned(aktprocsym^.definition^.localst) then
+        sym:=aktprocsym^.definition^.localst^.search(base)
+      else
+        sym:=nil;
+      if assigned(sym) then
+      begin
+        { field of local record variable. }
+        if (sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef) then
+          begin
+             p:=pvarsym(precdef(pvarsym(sym)^.definition)^.symtable^.search(field));
+             if assigned(pvarsym(p)) then
+             Begin
+                Offset := pvarsym(p)^.address;
+                GetVarOffset := TRUE;
+                Exit;
+             end;
+          end;
+      end
+      else
+       begin
+        { field of local record parameter to routine. }
+         if assigned(aktprocsym^.definition^.parast) then
+            sym:=aktprocsym^.definition^.parast^.search(base)
+         else
+           sym:=nil;
+         if assigned(sym) then
+         begin
+           if (sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef)
+           then
+           begin
+             p:=pvarsym(precdef(pvarsym(sym)^.definition)^.symtable^.search(field));
+             if assigned(p) then
+             Begin
+                Offset := pvarsym(p)^.address;
+                GetVarOffset := TRUE;
+                Exit;
+             end;
+           end; { endif }
+         end; {endif }
+       end; { endif }
+     end;
+
+     { not found.. .now look for global variables. }
+     getsym(base,false);
+     sym:=srsym;
+     if assigned(sym) then
+     Begin
+        { field of global record variable. }
+        if (sym^.typ=varsym) and (pvarsym(sym)^.definition^.deftype=recorddef) then
+          begin
+             p:=pvarsym(precdef(pvarsym(sym)^.definition)^.symtable^.search(field));
+             if assigned(p) then
+             Begin
+                Offset := pvarsym(p)^.address;
+                GetVarOffset := TRUE;
+                Exit;
+             end;
+          end
+        else
+        { field of global record type constant. }
+        if (sym^.typ=typedconstsym) and (ptypedconstsym(sym)^.definition^.deftype=recorddef)
+          then
+          begin
+             p:=pvarsym(precdef(pvarsym(sym)^.definition)^.symtable^.search(field));
+             if assigned(p) then
+             Begin
+                Offset := pvarsym(p)^.address;
+                GetVarOffset := TRUE;
+                Exit;
+             end;
+          end
+     end; { end looking for global variables .. }
+  end;
+
+
+
+  Function GetTypeOffset(const base: string; const field: string;
+    Var Offset: longint):boolean;
+  { search and returns the offset of records/objects of the base }
+  { with field name setup in field.                              }
+  { returns 0 if not found.                                      }
+  { used when base is a variable or a typed constant name.       }
+   var
+    sym:psym;
+    p: psym;
+  Begin
+     Offset := 0;
+     GetTypeOffset := FALSE;
+     { local list }
+     if assigned(aktprocsym) then
+     begin
+      if assigned(aktprocsym^.definition^.localst) then
+        sym:=aktprocsym^.definition^.localst^.search(base)
+      else
+        sym:=nil;
+      if assigned(sym) then
+      begin
+        { field of local record type. }
+        if (sym^.typ=typesym) and (ptypesym(sym)^.definition^.deftype=recorddef) then
+          begin
+             p:=precdef(ptypesym(sym)^.definition)^.symtable^.search(field);
+             if assigned(p) then
+             Begin
+                Offset := pvarsym(p)^.address;
+                GetTypeOffset := TRUE;
+                Exit;
+             end;
+          end;
+      end
+      else
+       begin
+        { field of local record type to routine. }
+         if assigned(aktprocsym^.definition^.parast) then
+            sym:=aktprocsym^.definition^.parast^.search(base)
+         else
+           sym:=nil;
+         if assigned(sym) then
+         begin
+           if (sym^.typ=typesym) and (ptypesym(sym)^.definition^.deftype=recorddef)
+           then
+           begin
+             p:=precdef(ptypesym(sym)^.definition)^.symtable^.search(field);
+             if assigned(p) then
+             Begin
+                Offset := pvarsym(p)^.address;
+                GetTypeOffset := TRUE;
+                Exit;
+             end;
+           end; { endif }
+         end; {endif }
+       end; { endif }
+     end;
+
+     { not found.. .now look for global types. }
+     getsym(base,false);
+     sym:=srsym;
+     if assigned(sym) then
+     Begin
+        { field of global record types. }
+        if (sym^.typ=typesym) and (ptypesym(sym)^.definition^.deftype=recorddef) then
+          begin
+             p:=precdef(ptypesym(sym)^.definition)^.symtable^.search(field);
+             if assigned(p) then
+             Begin
+                Offset := pvarsym(p)^.address;
+                GetTypeOffset := TRUE;
+                Exit;
+             end
+          end
+        else
+        { public field names of objects }
+        if (sym^.typ=typesym) and (ptypesym(sym)^.definition^.deftype=objectdef)then
+          begin
+             if assigned(pobjectdef(ptypesym(sym)^.definition)^.publicsyms) then
+             Begin
+               p:=pobjectdef(ptypesym(sym)^.definition)^.publicsyms^.search(field);
+               if assigned(p) then
+               Begin
+                  Offset := pvarsym(p)^.address;
+                  GetTypeOffset := TRUE;
+                  Exit;
+               end
+             end;
+          end;
+     end; { end looking for global variables .. }
+  end;
+
+
+  Function CreateVarInstr(var Instr: TInstruction; const hs:string;operandnum:byte): Boolean;
+  { search and sets up the correct fields in the Instr record }
+  { for the NON-constant identifier passed to the routine.    }
+  { if not found returns FALSE.                               }
+   var
+    sym:psym;
+    l: longint;
+  Begin
+     CreateVarInstr := FALSE;
+     { are we in a routine ? }
+     if assigned(aktprocsym) then
+     begin
+      if assigned(aktprocsym^.definition^.localst) then
+      { search the local list for the name of this variable. }
+        sym:=aktprocsym^.definition^.localst^.search(hs)
+      else
+        sym:=nil;
+      if assigned(sym) then
+      begin
+        if sym^.typ=varsym then
+          begin
+           { we always assume in asm statements that     }
+           { that the variable is valid.                 }
+           pvarsym(sym)^.is_valid:=1;
+           instr.operands[operandnum].ref.base := procinfo.framepointer;
+           instr.operands[operandnum].ref.offset := - (pvarsym(sym)^.address);
+           { the current size is NOT overriden if it already }
+           { exists, such as in the case of a byte ptr, in   }
+           { front of the identifier.                        }
+           if instr.operands[operandnum].size = S_NO then
+           Begin
+             case pvarsym(sym)^.getsize of
+              1: instr.operands[operandnum].size := S_B;
+              2: instr.operands[operandnum].size := S_W;
+              4: instr.operands[operandnum].size := S_L;
+              8: instr.operands[operandnum].size := S_Q;
+              extended_size: 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; { end case }
+           end;
+           { ok, finished for thir variable. }
+           CreateVarInstr := TRUE;
+           Exit;
+          end
+        else
+        { call to local function }
+        if (sym^.typ=procsym) then
+          begin
+            { 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(pprocsym(sym)^.definition^.mangledname);
+            CreateVarInstr := TRUE;
+            Exit;
+          end
+{        else
+        if (sym^.typ = typedconstsym) then
+        Begin}
+           { UGH????? pprocsym??? }
+{           instr.operands[operandnum].ref.symbol:=newpasstr(pprocsym(sym)^.definition^.mangledname);}
+           {* the current size is NOT overriden if it already *}
+           {* exists, such as in the case of a byte ptr, in   *}
+           {* front of the identifier.                        *}
+{           if instr.operands[operandnum].size = S_NO then
+           Begin
+             case ptypedconstsym(sym)^.definition^.size of
+              1: instr.operands[operandnum].size := S_B;
+              2: instr.operands[operandnum].size := S_W;
+              4: instr.operands[operandnum].size := S_L;
+              8: instr.operands[operandnum].size := S_Q;
+              extended_size: 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;} {* end case *}
+{           end;}
+           {* ok, finished for this variable. *}
+{           CreateVarInstr := TRUE;
+           Exit;
+        end }
+      end;
+      { now check for parameters passed to routine }
+{      else}
+       begin
+         if assigned(aktprocsym^.definition^.parast) then
+            sym:=aktprocsym^.definition^.parast^.search(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);
+             pvarsym(sym)^.is_valid:=1;
+             instr.operands[operandnum].ref.base := procinfo.framepointer;
+             instr.operands[operandnum].ref.offset := l;
+             { the current size is NOT overriden if it already }
+             { exists, such as in the case of a byte ptr, in   }
+             { front of the identifier.                        }
+             if instr.operands[operandnum].size = S_NO then
+             Begin
+               case pvarsym(sym)^.getsize of
+                 1: instr.operands[operandnum].size := S_B;
+                 2: instr.operands[operandnum].size := S_W;
+                 4: instr.operands[operandnum].size := S_L;
+                 8: instr.operands[operandnum].size := S_Q;
+                 extended_size: 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; { end case }
+             end; { endif }
+             CreateVarInstr := TRUE;
+             Exit;
+           end; { endif }
+         end; {endif }
+       end; { endif }
+     end;
+
+     { not found.. .now look for global variables. }
+     getsym(hs,false);
+     sym:=srsym;
+     if assigned(sym) then
+     Begin
+       if (sym^.typ = varsym) or (sym^.typ = typedconstsym) then
+       Begin
+       { 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(sym^.mangledname);
+         { the current size is NOT overriden if it already }
+         { exists, such as in the case of a byte ptr, in   }
+         { front of the identifier.                        }
+         if (instr.operands[operandnum].size = S_NO) and (sym^.typ = varsym) then
+         Begin
+           case pvarsym(sym)^.getsize of
+             1: instr.operands[operandnum].size := S_B;
+             2: instr.operands[operandnum].size := S_W;
+             4: instr.operands[operandnum].size := S_L;
+             8: instr.operands[operandnum].size := S_Q;
+           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;
+         end
+         else
+         if (instr.operands[operandnum].size = S_NO) and (sym^.typ = typedconstsym) then
+         Begin
+         { only these are valid sizes, otherwise prefixes are }
+         { required.                                          }
+            case ptypedconstsym(sym)^.definition^.size of
+              1: instr.operands[operandnum].size := S_B;
+              2: instr.operands[operandnum].size := S_W;
+              4: instr.operands[operandnum].size := S_L;
+              8: instr.operands[operandnum].size := S_Q;
+            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;
+         end; { endif }
+         CreateVarInstr := TRUE;
+         Exit;
+       end;
+       if (sym^.typ=procsym) then
+       begin
+         if assigned(pprocsym(sym)^.definition^.nextoverloaded) then
+          Message(assem_w_calling_overload_func);
+         { 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(pprocsym(sym)^.definition^.mangledname);
+         CreateVarInstr := TRUE;
+         Exit;
+       end;
+     end; { end looking for global variables .. }
+  end;
+
+
+
+  Function SearchLabel(const s: string; var hl: plabel): boolean;
+  {**********************************************************************}
+  {  Description: Searches for a pascal label definition, first in the   }
+  {  local symbol list and then in the global symbol list. If found then }
+  {  return pointer to label and return true, otherwise returns false.   }
+  {**********************************************************************}
+  var
+    sym: psym;
+  Begin
+    SearchLabel := FALSE;
+    if assigned(aktprocsym) then
+    Begin
+      { Check the local constants }
+    if assigned(aktprocsym^.definition) then
+    Begin
+        if assigned(aktprocsym^.definition^.localst) then
+          sym := aktprocsym^.definition^.localst^.search(s)
+      else
+       sym := nil;
+      if assigned(sym) then
+      Begin
+       if (sym^.typ = labelsym) then
+       Begin
+          hl:=plabelsym(sym)^.number;
+          SearchLabel := TRUE;
+          exit;
+       end;
+      end;
+    end;
+  end;
+    { Check the global label symbols... }
+    getsym(s,false);
+    if srsym <> nil then
+    Begin
+      if (srsym^.typ=labelsym) then
+      Begin
+        hl:=plabelsym(srsym)^.number;
+        SearchLabel:= TRUE;
+        exit;
+      end;
+    end;
+  end;
+
+
+ {*************************************************************************}
+ {                   Instruction Generation Utilities                      }
+ {*************************************************************************}
+
+
+   Procedure ConcatString(p : paasmoutput;s:string);
+  {*********************************************************************}
+  { PROCEDURE ConcatString(s:string);                                   }
+  {  Description: This routine adds the character chain pointed to in   }
+  {  s to the instruction linked list.                                  }
+  {*********************************************************************}
+  Var
+   pc: PChar;
+  Begin
+     getmem(pc,length(s)+1);
+     p^.concat(new(pai_string,init_pchar(strpcopy(pc,s))));
+  end;
+
+  Procedure ConcatPasString(p : paasmoutput;s:string);
+  {*********************************************************************}
+  { PROCEDURE ConcatPasString(s:string);                                }
+  {  Description: This routine adds the character chain pointed to in   }
+  {  s to the instruction linked list, contrary to ConcatString it      }
+  {  uses a pascal style string, so it conserves null characters.       }
+  {*********************************************************************}
+  Begin
+     p^.concat(new(pai_string,init(s)));
+  end;
+
+  Procedure ConcatDirect(p : paasmoutput;s:string);
+  {*********************************************************************}
+  { PROCEDURE ConcatDirect(s:string)                                    }
+  {  Description: This routine output the string directly to the asm    }
+  {  output, it is only sed when writing special labels in AT&T mode,   }
+  {  and should not be used without due consideration, since it may     }
+  {  cause problems.                                                    }
+  {*********************************************************************}
+  Var
+   pc: PChar;
+  Begin
+     getmem(pc,length(s)+1);
+     p^.concat(new(pai_direct,init(strpcopy(pc,s))));
+  end;
+
+
+
+
+   Procedure ConcatConstant(p: paasmoutput; value: longint; maxvalue: longint);
+  {*********************************************************************}
+  { PROCEDURE ConcatConstant(value: longint; maxvalue: longint);        }
+  {  Description: This routine adds the value constant to the current   }
+  {  instruction linked list.                                           }
+  {   maxvalue -> indicates the size of the data to initialize:         }
+  {                  $ff -> create a byte node.                         }
+  {                  $ffff -> create a word node.                       }
+  {                  $ffffffff -> create a dword node.                  }
+  {*********************************************************************}
+  Begin
+      if value > maxvalue then
+      Begin
+         Message(assem_e_constant_out_of_bounds);
+         { assuming a value of maxvalue }
+         value := maxvalue;
+      end;
+      if maxvalue = $ff then
+          p^.concat(new(pai_const,init_8bit(byte(value))))
+      else
+      if maxvalue = $ffff then
+          p^.concat(new(pai_const,init_16bit(word(value))))
+      else
+      if maxvalue = $ffffffff then
+          p^.concat(new(pai_const,init_32bit(longint(value))));
+  end;
+
+  Procedure ConcatRealConstant(p : paasmoutput;value: bestreal; real_typ : tfloattype);
+  {***********************************************************************}
+  { PROCEDURE ConcatRealConstant(value: bestreal; real_typ : tfloattype); }
+  {  Description: This routine adds the value constant to the current     }
+  {  instruction linked list.                                             }
+  {   real_typ -> indicates the type of the real data to initialize:      }
+  {                  s32real -> create a single node.                     }
+  {                  s64real -> create a double node.                     }
+  {                  s80real -> create an extended node.                  }
+  {                  s64bit ->  create a  comp node.                      }
+  {                  f32bit ->  create a  fixed node. (not used normally) }
+  {***********************************************************************}
+    Begin
+       case real_typ of
+          s32real : p^.concat(new(pai_single,init(value)));
+          s64real : p^.concat(new(pai_double,init(value)));
+          s80real : p^.concat(new(pai_extended,init(value)));
+          s64bit  : p^.concat(new(pai_comp,init(value)));
+          f32bit  : p^.concat(new(pai_const,init_32bit(trunc(value*$10000))));
+       end;
+    end;
+
+   Procedure ConcatLabel(p: paasmoutput;op : tasmop;var l : plabel);
+  {*********************************************************************}
+  { PROCEDURE ConcatLabel                                               }
+  {  Description: This routine either emits a label or a labeled        }
+  {  instruction to the linked list of instructions.                    }
+  {*********************************************************************}
+   begin
+         if op=A_LABEL then
+           p^.concat(new(pai_label,init(l)))
+         else
+           p^.concat(new(pai_labeled,init(op,l)))
+   end;
+
+   procedure ConcatPublic(p:paasmoutput;const s : string);
+  {*********************************************************************}
+  { PROCEDURE ConcatPublic                                              }
+  {  Description: This routine emits an global   definition to the      }
+  {  linked list of instructions.(used by AT&T styled asm)              }
+  {*********************************************************************}
+   begin
+       p^.concat(new(pai_symbol,init_global(s)));
+       { concat_internal(s,EXT_NEAR); done in aasm }
+   end;
+
+   procedure ConcatLocal(p:paasmoutput;const s : string);
+  {*********************************************************************}
+  { PROCEDURE ConcatLocal                                               }
+  {  Description: This routine emits an local    definition to the      }
+  {  linked list of instructions.                                       }
+  {*********************************************************************}
+   begin
+       p^.concat(new(pai_symbol,init(s)));
+       { concat_internal(s,EXT_NEAR); done in aasm }
+   end;
+
+  Procedure ConcatGlobalBss(const s : string;size : longint);
+  {*********************************************************************}
+  { PROCEDURE ConcatGlobalBss                                           }
+  {  Description: This routine emits an global  datablock   to the      }
+  {  linked list of instructions.                                       }
+  {*********************************************************************}
+   begin
+       bsssegment^.concat(new(pai_datablock,init_global(s,size)));
+       { concat_internal(s,EXT_NEAR); done in aasm }
+   end;
+
+  Procedure ConcatLocalBss(const s : string;size : longint);
+  {*********************************************************************}
+  { PROCEDURE ConcatLocalBss                                            }
+  {  Description: This routine emits a local datablcok      to the      }
+  {  linked list of instructions.                                       }
+  {*********************************************************************}
+   begin
+       bsssegment^.concat(new(pai_datablock,init(s,size)));
+       { concat_internal(s,EXT_NEAR); done in aasm }
+   end;
+
+  { add to list of external labels }
+  Procedure ConcatExternal(const s : string;typ : texternal_typ);
+  {*********************************************************************}
+  { PROCEDURE ConcatExternal                                            }
+  {  Description: This routine emits an external definition to the      }
+  {  linked list of instructions.(used by AT&T styled asm)              }
+  {*********************************************************************}
+  { check if in internal list and remove it there                       }
+  var p : pai_external;
+   begin
+       p:=search_assembler_symbol(internals,s,typ);
+       if p<>nil then internals^.remove(p);
+       concat_external(s,typ);
+   end;
+
+  { add to internal list of labels }
+  Procedure ConcatInternal(const s : string;typ : texternal_typ);
+  {*********************************************************************}
+  { PROCEDURE ConcatInternal                                            }
+  {  Description: This routine emits an internal definition of a symbol }
+  {  (used by AT&T styled asm for undefined labels)                     }
+  {*********************************************************************}
+   begin
+       concat_internal(s,typ);
+   end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:12  root
+  Initial revision
+
+  Revision 1.15  1998/03/10 01:17:14  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.14  1998/03/09 12:58:10  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.13  1998/03/03 16:45:16  peter
+    + message support for assembler parsers
+
+  Revision 1.12  1998/03/02 01:48:02  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.11  1998/02/13 10:34:34  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.10  1998/01/09 19:21:19  carl
+  + added support for m68k
+
+  Revision 1.7  1997/12/14 22:43:17  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.5  1997/12/09 13:23:54  carl
+  + less processor specific
+  - moved searching for externals/internal symbols from CreateVarInstr to
+    ratti386.pas (this would cause invalid stuff in rai386.pas!)
+
+  Revision 1.4  1997/12/04 12:20:39  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.3  1997/12/01 17:42:49  pierre
+     + added some more functionnality to the assembler parser
+
+  Revision 1.2  1997/11/27 17:55:11  carl
+  * made it compile under bp (one comment was nested)
+
+  Revision 1.1.1.1  1997/11/27 08:32:50  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
+
+ 11th november 1997:
+   * fixed problems when using reserved words TRUE and FALSE (CEC).
+ 22th november 1997:
+   * changed operator (reserved word) into _operator (PM).
+
+}

compiler/assemble.pas

@@ -0,0 +1,485 @@
+{
+    $Id$
+    Copyright (c) 1998 by the FPC development team
+
+    This unit handles the assemblerfile write and assembler calls of FPC
+
+    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 assemble;
+
+interface
+
+uses
+  dos,cobjects,globals,aasm;
+
+const
+{$ifdef tp}
+  AsmOutSize=1024;
+{$else}
+  AsmOutSize=10000;
+{$endif}
+
+
+{$ifdef i386}
+{ tof = (of_none,of_o,of_obj,of_masm,of_att,of_nasm,of_win32) }
+  AsBin : array[tof] of string[8]=('','as','nasm','masm','as','nasm','asw');
+{$endif}
+{$ifdef m68k}
+{ tof = (of_none,of_o,of_gas,of_mot,of_mit) }
+  AsBin : array[tof] of string[8]=('','','','','');
+{$endif}
+
+
+type
+  PAsmList=^TAsmList;
+  TAsmList=object
+    outcnt  : longint;
+    outbuf  : array[0..AsmOutSize-1] of char;
+    outfile : file;
+    constructor Init;
+    destructor Done;
+    Procedure AsmFlush;
+    Procedure AsmWrite(const s:string);
+    Procedure AsmWritePChar(p:pchar);
+    Procedure AsmWriteLn(const s:string);
+    Procedure AsmLn;
+    procedure OpenAsmList(const fn,fn2:string);
+    procedure CloseAsmList;
+    procedure WriteTree(p:paasmoutput);virtual;
+    procedure WriteAsmList;virtual;
+  end;
+
+  PAsmFile=^TAsmFile;
+  TAsmFile=object
+    asmlist : pasmlist;
+    path:dirstr;
+    asmfile,
+    objfile,
+    srcfile,
+    as_bin  : string;
+    Constructor Init(const fn:string);
+    Destructor Done;
+    Function FindAssembler(curr_of:tof):string;
+    Procedure WriteAsmSource;
+    Function CallAssembler(const command,para:string):Boolean;
+    Procedure RemoveAsm;
+    Function DoAssemble:boolean;
+  end;
+
+Implementation
+
+uses
+  script,files,systems,verbose
+{$ifdef linux}
+  ,linux
+{$endif}
+  ,strings
+{$ifdef i386}
+  ,ag386att,ag386int
+{$endif}
+{$ifdef m68k}
+  ,ag68kmot,ag68kgas,ag68kmit
+{$endif}
+  ;
+
+
+Function DoPipe:boolean;
+begin
+  DoPipe:=use_pipe and (not writeasmfile) and (current_module^.output_format=of_o);
+end;
+
+
+{*****************************************************************************
+                                  TASMLIST
+*****************************************************************************}
+
+Procedure TAsmList.AsmFlush;
+begin
+  if outcnt>0 then
+   begin
+     BlockWrite(outfile,outbuf,outcnt);
+     outcnt:=0;
+   end;
+end;
+
+
+Procedure TAsmList.AsmWrite(const s:string);
+begin
+  if OutCnt+length(s)>=AsmOutSize then
+   AsmFlush;
+  Move(s[1],OutBuf[OutCnt],length(s));
+  inc(OutCnt,length(s));
+end;
+
+
+Procedure TAsmList.AsmWriteLn(const s:string);
+begin
+  AsmWrite(s);
+  AsmWrite(target_info.newline);
+end;
+
+
+Procedure TAsmList.AsmWritePChar(p:pchar);
+var
+  i,j : longint;
+begin
+  i:=StrLen(p);
+  j:=i;
+  while j>0 do
+   begin
+     i:=min(j,AsmOutSize);
+     if OutCnt+i>=AsmOutSize then
+      AsmFlush;
+     Move(p[0],OutBuf[OutCnt],i);
+     inc(OutCnt,i);
+     dec(j,i);
+     p:=pchar(@p[i]);
+   end;
+end;
+
+
+
+
+Procedure TAsmList.AsmLn;
+begin
+  AsmWrite(target_info.newline);
+end;
+
+
+procedure TAsmList.OpenAsmList(const fn,fn2:string);
+begin
+{$ifdef linux}
+  if DoPipe then
+   begin
+     Message1(exec_i_assembling_pipe,fn);
+     POpen(outfile,'as -o '+fn2,'W');
+   end
+  else
+{$endif}
+   begin
+     Assign(outfile,fn);
+     {$I-}
+      Rewrite(outfile,1);
+     {$I+}
+     if ioresult<>0 then
+      Message1(exec_d_cant_create_asmfile,fn);
+   end;
+  outcnt:=0;
+end;
+
+
+procedure TAsmList.CloseAsmList;
+var
+  f : file;
+  l : longint;
+begin
+  AsmFlush;
+{$ifdef linux}
+  if DoPipe then
+   Close(outfile)
+  else
+{$endif}
+   begin
+   {Touch Assembler time to ppu time is there is a ppufilename}
+     if Assigned(current_module^.ppufilename) then
+      begin
+        Assign(f,current_module^.ppufilename^);
+        reset(f,1);
+        if ioresult=0 then
+         begin
+           getftime(f,l);
+           close(f);
+           reset(outfile,1);
+           setftime(outfile,l);
+         end;
+      end;
+     close(outfile);
+   end;
+end;
+
+
+procedure TAsmList.WriteTree(p:paasmoutput);
+begin
+end;
+
+
+procedure TAsmList.WriteAsmList;
+begin
+end;
+
+
+constructor TAsmList.Init;
+begin
+  OutCnt:=0;
+end;
+
+
+destructor TAsmList.Done;
+begin
+end;
+
+
+{*****************************************************************************
+                                  TASMFILE
+*****************************************************************************}
+
+Constructor TAsmFile.Init(const fn:string);
+var
+  name:namestr;
+  ext:extstr;
+begin
+{Create filenames for easier access}
+  fsplit(fn,path,name,ext);
+  srcfile:=fn;
+  asmfile:=path+name+target_info.asmext;
+  objfile:=path+name+target_info.objext;
+{Init output format}
+  case current_module^.output_format of
+{$ifdef i386}
+     of_o,
+     of_win32,
+     of_att:
+       asmlist:=new(pi386attasmlist,Init);
+     of_obj,
+     of_masm,
+     of_nasm:
+       asmlist:=new(pi386intasmlist,Init);
+{$endif}
+{$ifdef m68k}
+     of_o,
+   of_gas : asmlist:=new(pm68kgasasmlist,Init);
+   of_mot : asmlist:=new(pm68kmotasmlist,Init);
+   of_mit : asmlist:=new(pm68kmitasmlist,Init);
+{$endif}
+  else
+   internalerror(30000);
+  end;
+end;
+
+
+Destructor TAsmFile.Done;
+begin
+end;
+
+
+Procedure TAsmFile.WriteAsmSource;
+begin
+  asmlist^.OpenAsmList(asmfile,objfile);
+  asmlist^.WriteAsmList;
+  asmlist^.CloseAsmList;
+end;
+
+
+const
+  last_of  : tof=of_none;
+var
+  LastASBin : string;
+Function TAsmFile.FindAssembler(curr_of:tof):string;
+var
+  asfound : boolean;
+begin
+  if last_of<>curr_of then
+   begin
+     last_of:=curr_of;
+     LastASBin:=FindExe(asbin[curr_of],asfound);
+     if (not asfound) and (not externasm) then
+      begin
+        Message1(exec_w_assembler_not_found,LastASBin);
+        externasm:=true;
+      end;
+     if asfound then
+      Message1(exec_u_using_assembler,LastASBin);
+   end;
+  FindAssembler:=LastASBin;
+end;
+
+
+Function TAsmFile.CallAssembler(const command,para:string):Boolean;
+begin
+  if not externasm then
+   begin
+     swapvectors;
+     exec(command,para);
+     swapvectors;
+     if (dosexitcode<>0) then
+      begin
+        Message(exec_w_error_while_assembling);
+        callassembler:=false;
+        exit;
+      end
+     else
+      if (doserror<>0) then
+       begin
+         Message(exec_w_cant_call_assembler);
+         externasm:=true;
+       end;
+   end;
+  if externasm then
+   AsmRes.AddAsmCommand(command,para,asmfile);
+  callassembler:=true;
+end;
+
+
+procedure TAsmFile.RemoveAsm;
+var
+  g : file;
+  i : word;
+begin
+  if writeasmfile then
+   exit;
+  if ExternAsm then
+   AsmRes.AddDeleteCommand (AsmFile)
+  else
+   begin
+     assign(g,asmfile);
+     {$I-}
+      erase(g);
+     {$I+}
+     i:=ioresult;
+   end;
+end;
+
+
+Function TAsmFile.DoAssemble:boolean;
+begin
+  if DoPipe then
+   exit;
+  if not externasm then
+   Message1(exec_i_assembling,asmfile);
+  case current_module^.output_format of
+{$ifdef i386}
+   of_att : begin
+              externasm:=true; {Force Extern Asm}
+              if CallAssembler(FindAssembler(of_att),' -D -o '+objfile+' '+asmfile) then
+               RemoveAsm;
+            end;
+     of_o : begin
+              if CallAssembler(FindAssembler(of_o),'-D -o '+objfile+' '+asmfile) then
+               RemoveAsm;
+            end;
+ of_win32 : begin
+              if CallAssembler(FindAssembler(of_win32),'-D -o '+objfile+' '+asmfile) then
+               RemoveAsm;
+            end;
+  of_nasm : begin
+              if CallAssembler(FindAssembler(of_nasm),' -f coff -o '+objfile+' '+asmfile) then
+               RemoveAsm;
+            end;
+   of_obj : begin
+              if CallAssembler(FindAssembler(of_nasm),' -f obj -o '+objfile+' '+asmfile) then
+               RemoveAsm;
+            end;
+  of_masm : begin
+            { !! Nothing yet !! }
+            end;
+{$endif}
+{$ifdef m68k}
+     of_o,
+   of_mot,
+   of_mit,
+   of_gas : begin
+            { !! Nothing yet !! }
+            end;
+{$endif}
+  else
+   internalerror(30000);
+  end;
+  DoAssemble:=true;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:16  root
+  Initial revision
+
+  Revision 1.17  1998/03/10 13:23:00  florian
+    * small win32 problems fixed
+
+  Revision 1.16  1998/03/10 01:17:14  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.15  1998/03/09 10:37:41  peter
+    * fixed very long pchar writing (> outbufsize)
+
+  Revision 1.14  1998/03/05 22:43:45  florian
+    * some win32 support stuff added
+
+  Revision 1.13  1998/03/04 14:18:58  michael
+  * modified messaging system
+
+  Revision 1.12  1998/03/04 01:34:51  peter
+    * messages for unit-handling and assembler/linker
+    * the compiler compiles without -dGDB, but doesn't work yet
+    + -vh for Hint
+
+  Revision 1.11  1998/03/02 01:48:05  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.10  1998/02/26 11:57:00  daniel
+  * New assembler optimizations commented out, because of bugs.
+  * Use of dir-/name- and extstr.
+
+  Revision 1.9  1998/02/24 10:29:12  peter
+    * -a works again
+
+  Revision 1.8  1998/02/21 03:31:40  carl
+    + mit68k asm support.
+
+  Revision 1.7  1998/02/18 14:18:16  michael
+  + added log at end of file (retroactively)
+
+  revision 1.6
+  date: 1998/02/18 13:43:11;  author: michael;  state: Exp;  lines: +3 -19
+  + Implemented an OS independent AsmRes object.
+  ----------------------------
+  revision 1.5
+  date: 1998/02/17 21:20:28;  author: peter;  state: Exp;  lines: +60 -54
+    + Script unit
+    + __EXIT is called again to exit a program
+    - target_info.link/assembler calls
+    * linking works again for dos
+    * optimized a few filehandling functions
+    * fixed stabs generation for procedures
+  ----------------------------
+  revision 1.4
+  date: 1998/02/16 12:51:27;  author: michael;  state: Exp;  lines: +2 -2
+  + Implemented linker object
+  ----------------------------
+  revision 1.3
+  date: 1998/02/15 21:15:58;  author: peter;  state: Exp;  lines: +8 -9
+    * all assembler outputs supported by assemblerobject
+    * cleanup with assembleroutputs, better .ascii generation
+    * help_constructor/destructor are now added to the externals
+    - generation of asmresponse is not outputformat depended
+  ----------------------------
+  revision 1.2
+  date: 1998/02/14 01:45:04;  author: peter;  state: Exp;  lines: +3 -14
+    * more fixes
+    - pmode target is removed
+    - search_as_ld is removed, this is done in the link.pas/assemble.pas
+    + findexe() to search for an executable (linker,assembler,binder)
+  ----------------------------
+  revision 1.1
+  date: 1998/02/13 22:28:16;  author: peter;  state: Exp;
+    + Initial implementation
+}

compiler/browser.pas

@@ -0,0 +1,166 @@
+{
+    $Id$
+    Copyright (c) 1996-98 by Florian Klaempfl
+
+    This unit implements a browser object
+
+    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 browser;
+
+interface
+
+uses globals, files;
+
+type
+  pref = ^tref;
+  tref = object
+         nextref   : pref;
+         inputfile : pinputfile;
+         lineno    : longint;
+         constructor init(ref : pref);
+         constructor load(var ref : pref;fileindex : word;line : longint);
+         destructor done; virtual;
+         function  get_file_line : string;
+         end;
+
+  { simple method to chain all refs }
+  procedure add_new_ref(var ref : pref);
+
+  function get_source_file(index : word) : pinputfile;
+
+  { one big problem remains for overloaded procedure }
+  { we should be able to separate them               }
+  { this might be feasable in pass_1                 }
+
+implementation
+
+  constructor tref.init(ref :pref);
+
+    begin
+       nextref:=nil;
+       if ref<>nil then
+          ref^.nextref:=@self;
+       if current_module<>nil then
+         begin
+            inputfile:=current_module^.current_inputfile;
+            if inputfile<>nil then
+              begin
+                 inc(inputfile^.ref_index);
+                 lineno:=inputfile^.line_no;
+              end
+            else
+              lineno:=0;
+         end
+       else
+         begin
+            inputfile:=nil;
+            lineno:=0;
+         end;
+    end;
+
+  constructor tref.load(var ref : pref;fileindex : word;line : longint);
+
+    begin
+       if assigned(ref) then
+         ref^.nextref:=@self;
+       nextref:=nil;
+       inputfile:=get_source_file(fileindex);
+       lineno:=line;
+       ref:=@self;
+    end;
+
+  destructor tref.done;
+
+    begin
+       if inputfile<>nil then
+         dec(inputfile^.ref_count);
+    end;
+
+    function tref.get_file_line : string;
+
+      begin
+        get_file_line:='';
+        if inputfile=nil then exit;
+{$ifdef USE_RHIDE}
+        get_file_line:=lowercase(inputfile^.name^+inputfile^.ext^)+':'+tostr(lineno)+':'
+{$else  USE_RHIDE}
+        get_file_line:=inputfile^.name^+inputfile^.ext^+'('+tostr(lineno)+')'
+{$endif USE_RHIDE}
+      end;
+
+  procedure add_new_ref(var ref : pref);
+
+    var
+       newref : pref;
+
+    begin
+       new(newref,init(ref));
+       ref:=newref;
+    end;
+
+    function get_source_file(index : word) : pinputfile;
+
+      var
+         f : pinputfile;
+
+      begin
+         get_source_file:=nil;
+         f:=pinputfile(current_module^.sourcefiles.files);
+         while assigned(f) do
+           begin
+              if f^.ref_index=index then
+                begin
+                   get_source_file:=f;
+                   exit;
+                end;
+              f:=pinputfile(f^._next);
+           end;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:12  root
+  Initial revision
+
+  Revision 1.5  1998/03/10 16:27:36  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.4  1998/03/10 01:17:15  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.3  1998/03/02 01:48:06  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.2  1998/02/13 10:34:37  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.1.1.1  1997/11/27 08:32:51  michael
+  FPC Compiler CVS start
+}
+

compiler/catch.pas

@@ -0,0 +1,105 @@
+{
+    $Id$
+    Copyright (c) 1997-98 by Michael Van Canneyt
+
+    Unit to catch segmentation faults and Ctrl-C and exit gracefully
+    under linux and go32v2
+
+    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 catch;
+interface
+uses
+{$ifdef linux}
+  linux,
+{$endif}
+{$ifdef go32v2}
+  dpmiexcp,
+{$endif}
+  verbose;
+
+Var
+{$ifdef linux}
+  NewSignal,OldSigSegm,OldSigInt : PSignalHandler;
+{$else}
+  NewSignal,OldSigSegm,OldSigInt : SignalHandler;
+{$endif}
+
+
+Implementation
+
+{$ifdef linux}
+Procedure CatchSignal(Sig : Integer);
+{$else}
+Function CatchSignal(Sig : longint):longint;
+{$endif}
+begin
+  case Sig of
+   SIGSEGV : begin
+             { Temporary message - until we get an error number... }
+               writeln ('Panic : Internal compiler error, exiting.');
+               internalerror(9999);
+             end;
+    SIGINT : begin
+               WriteLn('Ctrl-C Signaled!');
+               Stop;
+             end;
+  end;
+{$ifndef linux}
+  CatchSignal:=0;
+{$endif}
+end;
+
+
+begin
+{$ifdef linux}
+  NewSignal:=PSignalHandler(@CatchSignal);
+  OldSigSegm:=Signal (SIGSEGV,NewSignal);
+  OldSigInt:=Signal (SIGINT,NewSignal);
+{$else}
+  NewSignal:=SignalHandler(@CatchSignal);
+  Signal (SIGSEGV,NewSignal);
+  Signal (SIGINT,NewSignal);
+{$endif}
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:12  root
+  Initial revision
+
+  Revision 1.5  1998/03/10 01:17:15  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.4  1998/03/02 01:48:07  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.3  1998/02/13 10:34:37  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.2  1998/01/27 23:34:35  peter
+    + SIGINT capture with exit. It works for linux and go32v2 (last one
+      not 100% yet)
+
+  Revision 1.1.1.1  1997/11/27 08:32:51  michael
+  FPC Compiler CVS start
+}

compiler/cg68k.pas

@@ -0,0 +1,5342 @@
+{
+    $Id$
+    Copyright (c) 1993,98 by Florian Klaempfl, Carl Eric Codere
+
+    This unit generates 68000 (or better) assembler from the parse tree
+
+    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.
+
+ ****************************************************************************}
+{$ifdef tp}
+{$E+,F+,N+,D+,L+,Y+}
+{$endif}
+
+{---------------------------------------------------------------------------}
+{ LEFT TO DO IN CG68k AND CG68k2                                            }
+{---------------------------------------------------------------------------}
+{  o Test and correct problems with extended support.                       }
+{  o Optimize secondmoddiv when doing a constant modulo.                    }
+{  o Add emulation support for Cardinal under MC68000.                      }
+{---------------------------------------------------------------------------}
+
+unit cg68k;
+
+
+{***************************************************************************}
+interface
+{***************************************************************************}
+
+uses    objects,verbose,cobjects,systems,globals,tree,
+        symtable,types,strings,pass_1,hcodegen,
+        aasm,m68k,tgen68k,files,cga68k,cg68k2,gdb,link;
+
+{ produces assembler for the expression in variable p }
+{ and produces an assembler node at the end           }
+procedure generatecode(var p : ptree);
+
+
+{ produces the actual code }
+function do_secondpass(var p : ptree) : boolean;
+
+procedure secondpass(var p : ptree);
+
+{$ifdef test_dest_loc}
+const   { used to avoid temporary assignments }
+        dest_loc_known : boolean = false;
+        in_dest_loc : boolean = false;
+        dest_loc_tree : ptree = nil;
+
+var dest_loc : tlocation;
+
+procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
+
+{$endif test_dest_loc}
+
+
+
+{***************************************************************************}
+implementation
+{***************************************************************************}
+
+    const
+       never_copy_const_param : boolean = false;
+       bytes2Sxx:array[1..4] of Topsize=(S_B,S_W,S_NO,S_L);
+        { used to avoid temporary assignments }
+        dest_loc_known : boolean = false;
+        in_dest_loc : boolean = false;
+        dest_loc_tree : ptree = nil;
+
+
+
+    var
+       { this is for open arrays and strings        }
+       { but be careful, this data is in the        }
+       { generated code destroyed quick, and also   }
+       { the next call of secondload destroys this  }
+       { data                                       }
+       { So be careful using the informations       }
+       { provided by this variables                 }
+       highframepointer : tregister;
+       highoffset : longint;
+       dest_loc : tlocation;
+
+        procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
+
+          begin
+             if (dest_loc.loc=LOC_CREGISTER) or (dest_loc.loc=LOC_REGISTER) then
+               begin
+                 emit_reg_reg(A_MOVE,s,reg,dest_loc.register);
+                 p^.location:=dest_loc;
+                 in_dest_loc:=true;
+               end
+             else
+             if (dest_loc.loc=LOC_REFERENCE) or (dest_loc.loc=LOC_MEM) then
+               begin
+                 exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,s,reg,newreference(dest_loc.reference))));
+                 p^.location:=dest_loc;
+                 in_dest_loc:=true;
+               end
+             else
+               internalerror(20080);
+          end;
+
+
+
+
+    procedure error(const t : tmsgconst);
+
+      begin
+         if not(codegenerror) then
+           verbose.Message(t);
+         codegenerror:=true;
+      end;
+
+    type
+       secondpassproc = procedure(var p : ptree);
+
+    procedure seconderror(var p : ptree);
+
+      begin
+         p^.error:=true;
+         codegenerror:=true;
+      end;
+
+    procedure secondload(var p : ptree);
+
+      var
+         hregister : tregister;
+         i : longint;
+         symtabletype: tsymtabletype;
+         hp : preference;
+
+      begin
+         simple_loadn:=true;
+         reset_reference(p^.location.reference);
+         case p^.symtableentry^.typ of
+              { this is only for toasm and toaddr }
+              absolutesym :
+                 begin
+                    stringdispose(p^.location.reference.symbol);
+                    p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
+                    if p^.symtableentry^.owner^.symtabletype=unitsymtable then
+                      concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
+                 end;
+              varsym :
+                 begin
+                    hregister:=R_NO;
+                    symtabletype:=p^.symtable^.symtabletype;
+                    { in case it is a register variable: }
+                    { we simply set the location to the  }
+                    { correct register.                  }
+                    if pvarsym(p^.symtableentry)^.reg<>R_NO then
+                      begin
+                         p^.location.loc:=LOC_CREGISTER;
+                         p^.location.register:=pvarsym(p^.symtableentry)^.reg;
+                         unused:=unused-[pvarsym(p^.symtableentry)^.reg];
+                      end
+                    else
+                      begin
+                         { --------------------- LOCAL AND TEMP VARIABLES ------------- }
+                         if (symtabletype=parasymtable) or (symtabletype=localsymtable) then
+                           begin
+
+                              p^.location.reference.base:=procinfo.framepointer;
+                              p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
+
+                              if (symtabletype=localsymtable) then
+                                p^.location.reference.offset:=-p^.location.reference.offset;
+
+                              if (symtabletype=parasymtable) then
+                                inc(p^.location.reference.offset,p^.symtable^.call_offset);
+
+                              if (lexlevel>(p^.symtable^.symtablelevel)) then
+                                begin
+                                   hregister:=getaddressreg;
+
+                                   { make a reference }
+                                   new(hp);
+                                   reset_reference(hp^);
+                                   hp^.offset:=procinfo.framepointer_offset;
+                                   hp^.base:=procinfo.framepointer;
+
+                                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,hregister)));
+
+                                   simple_loadn:=false;
+                                   i:=lexlevel-1;
+                                   while i>(p^.symtable^.symtablelevel) do
+                                     begin
+                                        { make a reference }
+                                        new(hp);
+                                        reset_reference(hp^);
+                                        hp^.offset:=8;
+                                        hp^.base:=hregister;
+
+                                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,hregister)));
+                                        dec(i);
+                                     end;
+                                   p^.location.reference.base:=hregister;
+                                end;
+                           end
+                         { --------------------- END OF LOCAL AND TEMP VARS ---------------- }
+                         else
+                           case symtabletype of
+                              unitsymtable,globalsymtable,
+                              staticsymtable : begin
+                                                  stringdispose(p^.location.reference.symbol);
+                                                  p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
+                                                   if symtabletype=unitsymtable then
+                                                     concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
+                                               end;
+                              objectsymtable : begin
+                                                  if (pvarsym(p^.symtableentry)^.properties and sp_static)<>0 then
+                                                    begin
+                                                       stringdispose(p^.location.reference.symbol);
+                                                       p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
+                                                        if p^.symtable^.defowner^.owner^.symtabletype=unitsymtable then
+                                                          concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
+                                                    end
+                                                  else
+                                                    begin
+                                                  p^.location.reference.base:=R_A5;
+                                                  p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
+                                               end;
+                                               end;
+                              withsymtable :   begin
+                                                  hregister:=getaddressreg;
+                                                  p^.location.reference.base:=hregister;
+                                                  { make a reference }
+                                                  new(hp);
+                                                  reset_reference(hp^);
+                                                  hp^.offset:=p^.symtable^.datasize;
+                                                  hp^.base:=procinfo.framepointer;
+
+                                                  exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,hregister)));
+
+                                                  p^.location.reference.offset:=
+                                                    pvarsym(p^.symtableentry)^.address;
+                                               end;
+                           end;
+
+                         { in case call by reference, then calculate: }
+                         if (pvarsym(p^.symtableentry)^.varspez=vs_var) or
+                            ((pvarsym(p^.symtableentry)^.varspez=vs_const) and
+                             dont_copy_const_param(pvarsym(p^.symtableentry)^.definition)) then
+                           begin
+                              simple_loadn:=false;
+                              if hregister=R_NO then
+                                hregister:=getaddressreg;
+                              { ADDED FOR OPEN ARRAY SUPPORT. }
+                              if (p^.location.reference.base=procinfo.framepointer) then
+                                begin
+                                   highframepointer:=p^.location.reference.base;
+                                   highoffset:=p^.location.reference.offset;
+                                end
+                              else
+                                begin
+                                   highframepointer:=R_A1;
+                                   highoffset:=p^.location.reference.offset;
+                                   exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
+                                     p^.location.reference.base,R_A1)));
+                                end;
+                              exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),
+                                hregister)));
+                              { END ADDITION }
+                              clear_reference(p^.location.reference);
+                              p^.location.reference.base:=hregister;
+                          end;
+                         { should be dereferenced later (FK)
+                         if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and
+                           ((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oois_class)<>0) then
+                           begin
+                              simple_loadn:=false;
+                              if hregister=R_NO then
+                                hregister:=getaddressreg;
+                              exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),
+                                hregister)));
+                              clear_reference(p^.location.reference);
+                              p^.location.reference.base:=hregister;
+                           end;
+                         }
+                      end;
+                 end;
+              procsym:
+                 begin
+                    {!!!!! Be aware, work on virtual methods too }
+                    stringdispose(p^.location.reference.symbol);
+                    p^.location.reference.symbol:=
+                      stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname);
+                    if p^.symtable^.symtabletype=unitsymtable then
+                    concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
+                 end;
+              typedconstsym :
+                 begin
+                    stringdispose(p^.location.reference.symbol);
+                    p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
+                    if p^.symtable^.symtabletype=unitsymtable then
+                    concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
+                 end;
+              else internalerror(4);
+         end;
+      end;
+
+
+    { D0 and D1 used as temp (ok)   }
+    procedure secondmoddiv(var p : ptree);
+
+      var
+         hreg1 : tregister;
+         power : longint;
+         hl : plabel;
+         reg: tregister;
+         pushed: boolean;
+      begin
+         secondpass(p^.left);
+         set_location(p^.location,p^.left^.location);
+         pushed:=maybe_push(p^.right^.registers32,p);
+         secondpass(p^.right);
+         if pushed then restore(p);
+
+         { put numerator in register }
+         if p^.left^.location.loc<>LOC_REGISTER then
+           begin
+              if p^.left^.location.loc=LOC_CREGISTER then
+                begin
+                  hreg1:=getregister32;
+                  emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hreg1);
+                end
+              else
+                begin
+                  del_reference(p^.left^.location.reference);
+                  hreg1:=getregister32;
+                  exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
+                    hreg1)));
+                end;
+              p^.left^.location.loc:=LOC_REGISTER;
+              p^.left^.location.register:=hreg1;
+           end
+         else hreg1:=p^.left^.location.register;
+
+         if (p^.treetype=divn) and (p^.right^.treetype=ordconstn) and
+            ispowerof2(p^.right^.value,power) then
+           begin
+              exprasmlist^.concat(new(pai68k, op_reg(A_TST, S_L, hreg1)));
+              getlabel(hl);
+              emitl(A_BPL,hl);
+              if (power = 1) then
+                 exprasmlist^.concat(new(pai68k, op_const_reg(A_ADDQ, S_L,1, hreg1)));
+              if (p^.right^.value-1) < 9 then
+                 exprasmlist^.concat(new(pai68k, op_const_reg(A_ADDQ, S_L,p^.right^.value-1, hreg1)))
+              else
+                 exprasmlist^.concat(new(pai68k, op_const_reg(A_ADD, S_L,p^.right^.value-1, hreg1)));
+              emitl(A_LABEL, hl);
+              if (power > 0) and (power < 9) then
+                 exprasmlist^.concat(new(pai68k, op_const_reg(A_ASR, S_L,power, hreg1)))
+              else
+               begin
+                  exprasmlist^.concat(new(pai68k, op_const_reg(A_MOVE,S_L,power, R_D0)));
+                  exprasmlist^.concat(new(pai68k, op_reg_reg(A_ASR,S_L,R_D0, hreg1)));
+               end;
+           end
+         else
+           begin
+              { bring denominator to D1 }
+              { D1 is always free, it's }
+              { only used for temporary  }
+              { purposes                 }
+              if (p^.right^.location.loc<>LOC_REGISTER) and
+                 (p^.right^.location.loc<>LOC_CREGISTER) then
+                 begin
+                   del_reference(p^.right^.location.reference);
+                   p^.left^.location.loc:=LOC_REGISTER;
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference),R_D1)));
+                end
+             else
+              begin
+                   ungetregister32(p^.right^.location.register);
+                   emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,R_D1);
+              end;
+
+              { on entering this section D1 should contain the divisor }
+
+              if (opt_processors = MC68020) then
+              begin
+                 if (p^.treetype = modn) then
+                 Begin
+                   reg := getregister32;
+                   exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,reg)));
+                   getlabel(hl);
+                   { here what we do is prepare the high register with the     }
+                   { correct sign. i.e we clear it, check if the low dword reg }
+                   { which will participate in the division is signed, if so we}
+                   { we extend the sign to the high doword register by inverting }
+                   { all the bits.                                             }
+                   exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,hreg1)));
+                   emitl(A_BPL,hl);
+                   exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,reg)));
+                   emitl(A_LABEL,hl);
+                   { reg:hreg1 / d1 }
+                   exprasmlist^.concat(new(pai68k,op_reg_reg_reg(A_DIVSL,S_L,R_D1,reg,hreg1)));
+                   { hreg1 already contains quotient }
+                   { looking for remainder }
+                   exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,reg,hreg1)));
+                   ungetregister32(reg);
+                 end
+                 else
+                 { simple division... }
+                 Begin
+                   { reg:hreg1 / d1 }
+                   exprasmlist^.concat(new(pai68k,op_reg_reg(A_DIVS,S_L,R_D1,hreg1)));
+                 end;
+              end
+              else { MC68000 operations }
+                 begin
+                     { put numerator in d0 }
+                     emit_reg_reg(A_MOVE,S_L,hreg1,R_D0);
+                     { operation to perform on entry to both }
+                     { routines...  d0/d1                    }
+                     { return result in d0                   }
+                     if p^.treetype = divn then
+                       emitcall('LONGDIV',true)
+                     else
+                       emitcall('LONGMOD',true);
+                     emit_reg_reg(A_MOVE,S_L,R_D0,hreg1);
+              end; { endif }
+         end;
+         { this registers are always used when div/mod are present }
+         usedinproc:=usedinproc or ($800 shr word(R_D1));
+         usedinproc:=usedinproc or ($800 shr word(R_D0));
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=hreg1;
+      end;
+
+
+    { D6 used as scratch (ok) }
+    procedure secondshlshr(var p : ptree);
+
+      var
+         hregister1,hregister2,hregister3 : tregister;
+         op : tasmop;
+         pushed : boolean;
+      begin
+
+         secondpass(p^.left);
+         pushed:=maybe_push(p^.right^.registers32,p);
+         secondpass(p^.right);
+         if pushed then restore(p);
+
+         { load left operators in a register }
+         if p^.left^.location.loc<>LOC_REGISTER then
+           begin
+              if p^.left^.location.loc=LOC_CREGISTER then
+                begin
+                   hregister1:=getregister32;
+                   emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
+                     hregister1);
+                end
+              else
+                begin
+                   del_reference(p^.left^.location.reference);
+                   hregister1:=getregister32;
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
+                     hregister1)));
+                end;
+           end
+         else hregister1:=p^.left^.location.register;
+
+         { determine operator }
+         if p^.treetype=shln then
+           op:=A_LSL
+         else
+           op:=A_LSR;
+
+         { shifting by a constant directly decode: }
+         if (p^.right^.treetype=ordconstn) then
+           begin
+             if (p^.right^.location.reference.offset and 31 > 0) and (p^.right^.location.reference.offset and 31 < 9) then
+                 exprasmlist^.concat(new(pai68k,op_const_reg(op,S_L,p^.right^.location.reference.offset and 31,
+                   hregister1)))
+             else
+               begin
+                 exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,p^.right^.location.reference.offset and 31,
+                   R_D6)));
+                 exprasmlist^.concat(new(pai68k,op_reg_reg(op,S_L,R_D6,hregister1)));
+               end;
+              p^.location.loc:=LOC_REGISTER;
+              p^.location.register:=hregister1;
+           end
+         else
+           begin
+              { load right operators in a register }
+              if p^.right^.location.loc<>LOC_REGISTER then
+                begin
+                   if p^.right^.location.loc=LOC_CREGISTER then
+                     begin
+                        hregister2:=getregister32;
+                        emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,
+                          hregister2);
+                     end
+                   else
+                     begin
+                        del_reference(p^.right^.location.reference);
+                        hregister2:=getregister32;
+                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference),
+                          hregister2)));
+                     end;
+                end
+              else hregister2:=p^.right^.location.register;
+
+
+              emit_reg_reg(op,S_L,hregister2,hregister1);
+              p^.location.register:=hregister1;
+           end;
+         { this register is always used when shl/shr are present }
+         usedinproc:=usedinproc or ($800 shr byte(R_D6));
+      end;
+
+
+    procedure secondrealconst(var p : ptree);
+
+      var
+         hp1 : pai;
+         lastlabel : plabel;
+         found : boolean;
+
+      begin
+         clear_reference(p^.location.reference);
+         lastlabel:=nil;
+         found:=false;
+         { const already used ? }
+         if p^.labnumber=-1 then
+           begin
+              { tries to found an old entry }
+              hp1:=pai(consts^.first);
+              while assigned(hp1) do
+                begin
+                   if hp1^.typ=ait_label then
+                     lastlabel:=pai_label(hp1)^.l
+                   else
+                     begin
+                        if (hp1^.typ=p^.realtyp) and (lastlabel<>nil) then
+                          begin
+                             { Florian this caused a internalerror(10)=> no free reg !! }
+                             {if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) or
+                               ((p^.realtyp=ait_real_80bit) and (pai_extended(hp1)^.value=p^.valued)) or
+                               ((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then }
+                             if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) then
+                               found:=true;
+                             if ((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then
+                               found:=true;
+                             if ((p^.realtyp=ait_real_extended) and (pai_extended(hp1)^.value=p^.valued)) then
+                               found:=true;
+                             if found then
+                               begin
+                                  { found! }
+                                  p^.labnumber:=lastlabel^.nb;
+                                  break;
+                               end;
+                          end;
+                        lastlabel:=nil;
+                     end;
+                   hp1:=pai(hp1^.next);
+                end;
+              { :-(, we must generate a new entry }
+                 if p^.labnumber=-1 then
+                begin
+                   getlabel(lastlabel);
+                   p^.labnumber:=lastlabel^.nb;
+                   case p^.realtyp of
+                     ait_real_64bit : consts^.insert(new(pai_double,init(p^.valued)));
+                     ait_real_32bit : consts^.insert(new(pai_single,init(p^.valued)));
+                     ait_real_extended : consts^.insert(new(pai_extended,init(p^.valued)));
+                     else
+                       internalerror(10120);
+                     end;
+                   consts^.insert(new(pai_label,init(lastlabel)));
+                end;
+           end;
+         stringdispose(p^.location.reference.symbol);
+         p^.location.reference.symbol:=stringdup(lab2str(lastlabel));
+      end;
+
+    procedure secondfixconst(var p : ptree);
+
+      begin
+         { an fix comma const. behaves as a memory reference }
+         p^.location.loc:=LOC_MEM;
+         p^.location.reference.isintvalue:=true;
+         p^.location.reference.offset:=p^.valuef;
+      end;
+
+    procedure secondordconst(var p : ptree);
+
+      begin
+         { an integer const. behaves as a memory reference }
+         p^.location.loc:=LOC_MEM;
+         p^.location.reference.isintvalue:=true;
+         p^.location.reference.offset:=p^.value;
+      end;
+
+    procedure secondniln(var p : ptree);
+
+      begin
+         p^.location.loc:=LOC_MEM;
+         p^.location.reference.isintvalue:=true;
+         p^.location.reference.offset:=0;
+      end;
+
+    procedure secondstringconst(var p : ptree);
+
+      var
+         hp1 : pai;
+         lastlabel : plabel;
+         pc : pchar;
+         same_string : boolean;
+         i : word;
+
+      begin
+         clear_reference(p^.location.reference);
+         lastlabel:=nil;
+         { const already used ? }
+         if p^.labstrnumber=-1 then
+           begin
+              { tries to found an old entry }
+              hp1:=pai(consts^.first);
+              while assigned(hp1) do
+                begin
+                   if hp1^.typ=ait_label then
+                     lastlabel:=pai_label(hp1)^.l
+                   else
+                     begin
+                        if (hp1^.typ=ait_string) and (lastlabel<>nil) and
+                          (pai_string(hp1)^.len=length(p^.values^)+2) then
+                          begin
+                             same_string:=true;
+                             for i:=1 to length(p^.values^) do
+                               if pai_string(hp1)^.str[i]<>p^.values^[i] then
+                                 begin
+                                    same_string:=false;
+                                    break;
+                                 end;
+                             if same_string then
+                               begin
+                                  { found! }
+                                  p^.labstrnumber:=lastlabel^.nb;
+                                  break;
+                               end;
+                          end;
+                        lastlabel:=nil;
+                     end;
+                   hp1:=pai(hp1^.next);
+                end;
+              { :-(, we must generate a new entry }
+              if p^.labstrnumber=-1 then
+                begin
+                   getlabel(lastlabel);
+                   p^.labstrnumber:=lastlabel^.nb;
+                   getmem(pc,length(p^.values^)+3);
+                   move(p^.values^,pc^,length(p^.values^)+1);
+                   pc[length(p^.values^)+1]:=#0;
+                   { we still will have a problem if there is a #0 inside the pchar }
+                   consts^.insert(new(pai_string,init_pchar(pc)));
+                   { to overcome this problem we set the length explicitly }
+                   { with the ending null char }
+                   pai_string(consts^.first)^.len:=length(p^.values^)+2;
+                   consts^.insert(new(pai_label,init(lastlabel)));
+                end;
+           end;
+         stringdispose(p^.location.reference.symbol);
+         p^.location.reference.symbol:=stringdup(lab2str(lastlabel));
+         p^.location.loc := LOC_MEM;
+      end;
+
+    procedure secondumminus(var p : ptree);
+
+      begin
+         secondpass(p^.left);
+         p^.location.loc:=LOC_REGISTER;
+         case p^.left^.location.loc of
+            LOC_REGISTER : begin
+                              p^.location.register:=p^.left^.location.register;
+                              exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_L,p^.location.register)));
+                           end;
+            LOC_CREGISTER : begin
+                               p^.location.register:=getregister32;
+                               emit_reg_reg(A_MOVE,S_L,p^.location.register,
+                                 p^.location.register);
+                               exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_L,p^.location.register)));
+                            end;
+            LOC_REFERENCE,LOC_MEM :
+                           begin
+                              del_reference(p^.left^.location.reference);
+                              { change sign of a floating point  }
+                              { in the case of emulation, get    }
+                              { a free register, and change sign }
+                              { manually.                        }
+                              { otherwise simply load into an FPU}
+                              { register.                        }
+                              if (p^.left^.resulttype^.deftype=floatdef) and
+                                 (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then
+                                begin
+                                   { move to FPU }
+                                   floatload(pfloatdef(p^.left^.resulttype)^.typ,
+                                     p^.left^.location.reference,p^.location);
+                                   if (cs_fp_emulation) in aktswitches then
+                                       { if in emulation mode change sign manually }
+                                       exprasmlist^.concat(new(pai68k,op_const_reg(A_BCHG,S_L,31,
+                                          p^.location.fpureg)))
+                                   else
+                                       exprasmlist^.concat(new(pai68k,op_reg(A_FNEG,S_X,
+                                          p^.location.fpureg)));
+                                end
+                              else
+                                begin
+                                   p^.location.register:=getregister32;
+                                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+                                     newreference(p^.left^.location.reference),
+                                     p^.location.register)));
+                                   exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_L,p^.location.register)));
+                                end;
+                           end;
+            LOC_FPU : begin
+                              p^.location.loc:=LOC_FPU;
+                              p^.location.fpureg := p^.left^.location.fpureg;
+                              if (cs_fp_emulation) in aktswitches then
+                                  exprasmlist^.concat(new(pai68k,op_const_reg(A_BCHG,S_L,31,p^.location.fpureg)))
+                              else
+                                 exprasmlist^.concat(new(pai68k,op_reg(A_FNEG,S_X,p^.location.fpureg)));
+                           end;
+         end;
+         emitoverflowcheck;
+      end;
+
+    { use of A6 is required only temp (ok) }
+    procedure secondaddr(var p : ptree);
+
+      begin
+         secondpass(p^.left);
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=getregister32;
+         {@ on a procvar means returning an address to the procedure that
+          is stored in it.}
+       { yes but p^.left^.symtableentry can be nil
+       for example on @self !! }
+         { symtableentry can be also invalid, if left is no tree node }
+         if (p^.left^.treetype=loadn) and
+          assigned(p^.left^.symtableentry) and
+            (p^.left^.symtableentry^.typ=varsym) and
+          (Pvarsym(p^.left^.symtableentry)^.definition^.deftype=
+           procvardef) then
+            exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+             newreference(p^.left^.location.reference),
+             p^.location.register)))
+         else
+           begin
+            exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
+             newreference(p^.left^.location.reference),R_A0)));
+            exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
+             R_A0,p^.location.register)));
+           end;
+         { for use of other segments }
+         { if p^.left^.location.reference.segment<>R_DEFAULT_SEG then
+             p^.location.segment:=p^.left^.location.reference.segment;
+         }
+         del_reference(p^.left^.location.reference);
+      end;
+
+    { register a6 used as scratch }
+    procedure seconddoubleaddr(var p : ptree);
+
+      begin
+         secondpass(p^.left);
+         p^.location.loc:=LOC_REGISTER;
+         del_reference(p^.left^.location.reference);
+         p^.location.register:=getregister32;
+         exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
+          newreference(p^.left^.location.reference),R_A0)));
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
+          R_A0,p^.location.register)));
+      end;
+
+    procedure secondnot(var p : ptree);
+
+      const
+         flagsinvers : array[F_E..F_BE] of tresflags =
+            (F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C,
+             F_A,F_AE,F_B,F_BE);
+
+      var
+         hl : plabel;
+
+      begin
+         if (p^.resulttype^.deftype=orddef) and
+            (porddef(p^.resulttype)^.typ=bool8bit) then
+              begin
+                 case p^.location.loc of
+                    LOC_JUMP : begin
+                                  hl:=truelabel;
+                                  truelabel:=falselabel;
+                                  falselabel:=hl;
+                                  secondpass(p^.left);
+                                  maketojumpbool(p^.left);
+                                  hl:=truelabel;
+                                  truelabel:=falselabel;
+                                  falselabel:=hl;
+                               end;
+                    LOC_FLAGS : begin
+                                   secondpass(p^.left);
+                                   p^.location.resflags:=flagsinvers[p^.left^.location.resflags];
+                                end;
+                    LOC_REGISTER : begin
+                                      secondpass(p^.left);
+                                      p^.location.register:=p^.left^.location.register;
+                                      exprasmlist^.concat(new(pai68k,op_const_reg(A_EOR,S_B,1,p^.location.register)));
+                                   end;
+                    LOC_CREGISTER : begin
+                                       secondpass(p^.left);
+                                       p^.location.loc:=LOC_REGISTER;
+                                       p^.location.register:=getregister32;
+                                       emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,
+                                         p^.location.register);
+                                       exprasmlist^.concat(new(pai68k,op_const_reg(A_EOR,S_B,1,p^.location.register)));
+                                    end;
+                    LOC_REFERENCE,LOC_MEM : begin
+                                              secondpass(p^.left);
+                                              del_reference(p^.left^.location.reference);
+                                              p^.location.loc:=LOC_REGISTER;
+                                              p^.location.register:=getregister32;
+                                              if p^.left^.location.loc=LOC_CREGISTER then
+                                                emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,
+                                                   p^.location.register)
+                                              else
+                                                exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,
+                                              newreference(p^.left^.location.reference),
+                                                p^.location.register)));
+                                              exprasmlist^.concat(new(pai68k,op_const_reg(A_EOR,S_B,1,p^.location.register)));
+                                           end;
+                 end;
+              end
+            else
+              begin
+                secondpass(p^.left);
+                p^.location.loc:=LOC_REGISTER;
+
+                case p^.left^.location.loc of
+                   LOC_REGISTER : begin
+                                     p^.location.register:=p^.left^.location.register;
+                                     exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));
+                                  end;
+                   LOC_CREGISTER : begin
+                                     p^.location.register:=getregister32;
+                                     emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
+                                       p^.location.register);
+                                     exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));
+                                   end;
+                   LOC_REFERENCE,LOC_MEM :
+                                  begin
+                                     del_reference(p^.left^.location.reference);
+                                     p^.location.register:=getregister32;
+                                     exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+                                       newreference(p^.left^.location.reference),
+                                       p^.location.register)));
+                                     exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));
+                                  end;
+                end;
+                {if  p^.left^.location.loc=loc_register then
+                  p^.location.register:=p^.left^.location.register
+                else
+                  begin
+                     del_locref(p^.left^.location);
+                     p^.location.register:=getregister32;
+                     exprasmlist^.concat(new(pai68k,op_loc_reg(A_MOV,S_L,
+                       p^.left^.location,
+                       p^.location.register)));
+                  end;
+                exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));}
+
+             end;
+      end;
+
+    procedure secondnothing(var p : ptree);
+
+      begin
+      end;
+
+    procedure secondassignment(var p : ptree);
+
+      var
+         opsize : topsize;
+         withresult : boolean;
+         otlabel,hlabel,oflabel : plabel;
+         hregister : tregister;
+         loc : tloc;
+
+      begin
+         otlabel:=truelabel;
+         oflabel:=falselabel;
+         getlabel(truelabel);
+         getlabel(falselabel);
+         withresult:=not(aktexprlevel<4);
+         { calculate left sides }
+         secondpass(p^.left);
+         case p^.left^.location.loc of
+            LOC_REFERENCE : begin
+                              { in case left operator uses too many registers }
+                              { but to few are free then LEA                  }
+                              if (p^.left^.location.reference.base<>R_NO) and
+                                 (p^.left^.location.reference.index<>R_NO) and
+                                 (usablereg32<p^.right^.registers32) then
+                                begin
+                                   del_reference(p^.left^.location.reference);
+                                   hregister:=getaddressreg;
+                                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(
+                                     p^.left^.location.reference),
+                                     hregister)));
+                                   clear_reference(p^.left^.location.reference);
+                                   p^.left^.location.reference.base:=hregister;
+                                   p^.left^.location.reference.index:=R_NO;
+                                end;
+                              loc:=LOC_REFERENCE;
+                           end;
+            LOC_CREGISTER : loc:=LOC_CREGISTER;
+            else
+               begin
+                  Message(cg_e_illegal_expression);
+                  exit;
+               end;
+         end;
+         { lets try to optimize this (PM)             }
+         { define a dest_loc that is the location      }
+         { and a ptree to verify that it is the right }
+         { place to insert it                         }
+{$ifdef test_dest_loc}
+         if (aktexprlevel<4) then
+           begin
+              dest_loc_known:=true;
+              dest_loc:=p^.left^.location;
+              dest_loc_tree:=p^.right;
+           end;
+{$endif test_dest_loc}
+
+         if (p^.right^.treetype=realconstn) then
+           begin
+              if p^.left^.resulttype^.deftype=floatdef then
+                begin
+                   case pfloatdef(p^.left^.resulttype)^.typ of
+                     s32real : p^.right^.realtyp:=ait_real_32bit;
+                     s64real : p^.right^.realtyp:=ait_real_64bit;
+                     s80real : p^.right^.realtyp:=ait_real_extended;
+                     { what about f32bit and s64bit }
+                     end;
+                end;
+           end;
+         secondpass(p^.right);
+{$ifdef test_dest_loc}
+         dest_loc_known:=false;
+         if in_dest_loc then
+           begin
+              truelabel:=otlabel;
+              falselabel:=oflabel;
+              in_dest_loc:=false;
+              exit;
+           end;
+{$endif test_dest_loc}
+         if p^.left^.resulttype^.deftype=stringdef then
+           begin
+             { we do not need destination anymore }
+             del_reference(p^.left^.location.reference);
+             { only source if withresult is set }
+             if not(withresult) then
+               del_reference(p^.right^.location.reference);
+             loadstring(p);
+             ungetiftemp(p^.right^.location.reference);
+           end
+         else case p^.right^.location.loc of
+            LOC_REFERENCE,
+            LOC_MEM : begin
+                         { handle ordinal constants trimmed }
+                         if (p^.right^.treetype in [ordconstn,fixconstn]) or
+                            (loc=LOC_CREGISTER) then
+                           begin
+                              case p^.left^.resulttype^.size of
+                                 1 : opsize:=S_B;
+                                 2 : opsize:=S_W;
+                                 4 : opsize:=S_L;
+                              end;
+                              if loc=LOC_CREGISTER then
+                                exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,
+                                  newreference(p^.right^.location.reference),
+                                  p^.left^.location.register)))
+                              else
+                                exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,opsize,
+                                  p^.right^.location.reference.offset,
+                                  newreference(p^.left^.location.reference))));
+                              {exprasmlist^.concat(new(pai68k,op_const_loc(A_MOV,opsize,
+                                  p^.right^.location.reference.offset,
+                                  p^.left^.location)));}
+                           end
+                         else
+                           begin
+                              concatcopy(p^.right^.location.reference,
+                                p^.left^.location.reference,p^.left^.resulttype^.size,
+                                withresult);
+                              ungetiftemp(p^.right^.location.reference);
+                           end;
+                      end;
+            LOC_REGISTER,
+            LOC_CREGISTER : begin
+                              case p^.right^.resulttype^.size of
+                                 1 : opsize:=S_B;
+                                 2 : opsize:=S_W;
+                                 4 : opsize:=S_L;
+                              end;
+                              { simplified with op_reg_loc         }
+                              if loc=LOC_CREGISTER then
+                                exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,opsize,
+                                  p^.right^.location.register,
+                                  p^.left^.location.register)))
+                              else
+                                exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,opsize,
+                                  p^.right^.location.register,
+                                  newreference(p^.left^.location.reference))));
+                              {exprasmlist^.concat(new(pai68k,op_reg_loc(A_MOV,opsize,
+                                  p^.right^.location.register,
+                                  p^.left^.location)));             }
+
+                           end;
+            LOC_FPU : begin
+                              if loc<>LOC_REFERENCE then
+                                internalerror(10010)
+                              else
+                                floatstore(pfloatdef(p^.left^.resulttype)^.typ,
+                                  p^.right^.location,p^.left^.location.reference);
+                      end;
+            LOC_JUMP     : begin
+                              getlabel(hlabel);
+                              emitl(A_LABEL,truelabel);
+                              if loc=LOC_CREGISTER then
+                                exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,
+                                  1,p^.left^.location.register)))
+                              else
+                                exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,
+                                  1,newreference(p^.left^.location.reference))));
+                              {exprasmlist^.concat(new(pai68k,op_const_loc(A_MOV,S_B,
+                                  1,p^.left^.location)));}
+                              emitl(A_JMP,hlabel);
+                              emitl(A_LABEL,falselabel);
+                              if loc=LOC_CREGISTER then
+                                exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_B,
+                                  p^.left^.location.register)))
+                              else
+                                exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,
+                                  0,newreference(p^.left^.location.reference))));
+                              emitl(A_LABEL,hlabel);
+                           end;
+            LOC_FLAGS    : begin
+                              if loc=LOC_CREGISTER then
+                               begin
+                                exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,
+                                  p^.left^.location.register)));
+                                exprasmlist^.concat(new(pai68k,op_reg(A_NEG,S_B,p^.left^.location.register)));
+                               end
+                              else
+                               begin
+                                 exprasmlist^.concat(new(pai68k,op_ref(flag_2_set[p^.right^.location.resflags],S_B,
+                                    newreference(p^.left^.location.reference))));
+                                 exprasmlist^.concat(new(pai68k,op_ref(A_NEG,S_B,newreference(p^.left^.location.reference))));
+                               end;
+
+                           end;
+         end;
+         truelabel:=otlabel;
+         falselabel:=oflabel;
+      end;
+
+    procedure secondderef(var p : ptree);
+
+      var
+         hr : tregister;
+
+      begin
+         secondpass(p^.left);
+         clear_reference(p^.location.reference);
+         case p^.left^.location.loc of
+            LOC_REGISTER : Begin
+                             hr := getaddressreg;
+                             emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
+                             p^.location.reference.base:=hr;
+                             ungetregister(p^.left^.location.register);
+                           end;
+            LOC_CREGISTER : begin
+                               { ... and reserve one for the pointer }
+                               hr:=getaddressreg;
+                               emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
+                                      p^.location.reference.base:=hr;
+                               { LOC_REGISTER indicates that this is a
+                               variable register which should not be freed. }
+{                               ungetregister(p^.left^.location.register); }
+                            end;
+            else
+              begin
+                 { free register }
+                 del_reference(p^.left^.location.reference);
+
+                 { ...and reserve one for the pointer }
+                 hr:=getaddressreg;
+                 exprasmlist^.concat(new(pai68k,op_ref_reg(
+                   A_MOVE,S_L,newreference(p^.left^.location.reference),
+                   hr)));
+                 p^.location.reference.base:=hr;
+              end;
+         end;
+      end;
+
+    { used D0, D1 as scratch (ok) }
+    { arrays ...                  }
+    { Sets up the array and string }
+    { references .                 }
+    procedure secondvecn(var p : ptree);
+
+      var
+         pushed : boolean;
+         ind : tregister;
+         _p : ptree;
+
+      procedure calc_emit_mul;
+
+        var
+           l1,l2 : longint;
+
+        begin
+           l1:=p^.resulttype^.size;
+           case l1 of
+              1     : p^.location.reference.scalefactor:=l1;
+              2 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,ind)));
+              4 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,ind)));
+              8 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,3,ind)));
+           else
+             begin
+               if ispowerof2(l1,l2) then
+                 exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,l2,ind)))
+                   else
+                 begin
+                   { use normal MC68000 signed multiply }
+                   if (l1 >= -32768) and (l1 <= 32767) then
+                     exprasmlist^.concat(new(pai68k,op_const_reg(A_MULS,S_W,l1,ind)))
+                   else
+                   { use long MC68020 long multiply }
+                   if (opt_processors = MC68020) then
+                     exprasmlist^.concat(new(pai68k,op_const_reg(A_MULS,S_L,l1,ind)))
+                   else
+                   { MC68000 long multiply }
+                     begin
+                       exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,l1,R_D0)));
+                       exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,ind,R_D1)));
+                       emitcall('LONGMUL',true);
+                       exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,ind)));
+                     end;
+                 end;
+             end; { else case }
+            end; { end case }
+        end; { calc_emit_mul }
+
+      var
+       extraoffset : longint;
+         t : ptree;
+         hp : preference;
+         tai:pai68k;
+       reg: tregister;
+
+      begin
+         secondpass(p^.left);
+         { RESULT IS IN p^.location.reference }
+         set_location(p^.location,p^.left^.location);
+
+         { offset can only differ from 0 if arraydef }
+         if p^.left^.resulttype^.deftype=arraydef then
+           dec(p^.location.reference.offset,
+             p^.resulttype^.size*
+             parraydef(p^.left^.resulttype)^.lowrange);
+
+         if p^.right^.treetype=ordconstn then
+           begin
+              { offset can only differ from 0 if arraydef }
+              if (p^.left^.resulttype^.deftype=arraydef) then
+              begin
+                   if not(is_open_array(p^.left^.resulttype)) then
+                       begin
+                     if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or
+                        (p^.right^.value<parraydef(p^.left^.resulttype)^.lowrange) then
+                        Message(parser_e_range_check_error);
+
+                     dec(p^.left^.location.reference.offset,
+                        p^.resulttype^.size*parraydef(p^.left^.resulttype)^.lowrange);
+                    end
+                   else
+                     begin
+                        { range checking for open arrays }
+                     end;
+                  end;
+              inc(p^.left^.location.reference.offset,
+                 p^.right^.value*p^.resulttype^.size);
+              p^.left^.resulttype:=p^.resulttype;
+              disposetree(p^.right);
+              _p:=p^.left;
+              putnode(p);
+              p:=_p;
+           end
+         else
+           begin
+              { quick hack, to overcome Delphi 2 }
+              if (cs_maxoptimieren in aktswitches) and
+                (p^.left^.resulttype^.deftype=arraydef) then
+                begin
+                   extraoffset:=0;
+                   if (p^.right^.treetype=addn) then
+                     begin
+                        if p^.right^.right^.treetype=ordconstn then
+                          begin
+                             extraoffset:=p^.right^.right^.value;
+                             t:=p^.right^.left;
+                             putnode(p^.right);
+                             putnode(p^.right^.right);
+                             p^.right:=t
+                          end
+                        else if p^.right^.left^.treetype=ordconstn then
+                          begin
+                             extraoffset:=p^.right^.left^.value;
+                             t:=p^.right^.right;
+                                    putnode(p^.right);
+                             putnode(p^.right^.left);
+                             p^.right:=t
+                          end;
+                     end
+                   else if (p^.right^.treetype=subn) then
+                     begin
+                              if p^.right^.right^.treetype=ordconstn then
+                          begin
+                             extraoffset:=p^.right^.right^.value;
+                             t:=p^.right^.left;
+                             putnode(p^.right);
+                             putnode(p^.right^.right);
+                             p^.right:=t
+                          end
+                        else if p^.right^.left^.treetype=ordconstn then
+                          begin
+                             extraoffset:=p^.right^.left^.value;
+                                    t:=p^.right^.right;
+                             putnode(p^.right);
+                             putnode(p^.right^.left);
+                             p^.right:=t
+                          end;
+                     end;
+                   inc(p^.location.reference.offset,
+                     p^.resulttype^.size*extraoffset);
+                end;
+              { calculate from left to right }
+              if (p^.location.loc<>LOC_REFERENCE) and
+                 (p^.location.loc<>LOC_MEM) then
+                Message(cg_e_illegal_expression);
+
+              pushed:=maybe_push(p^.right^.registers32,p);
+              secondpass(p^.right);
+              if pushed then restore(p);
+                 case p^.right^.location.loc of
+                LOC_REGISTER : begin
+                                 ind:=p^.right^.location.register;
+                                 case p^.right^.resulttype^.size of
+                                 1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
+                                      $ff,ind)));
+                                 2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
+                                      $ffff,ind)));
+                                 end;
+                               end;
+
+                LOC_CREGISTER : begin
+                                       ind:=getregister32;
+                                   emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,ind);
+                                   case p^.right^.resulttype^.size of
+                                   1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
+                                      $ff,ind)));
+                                   2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
+                                      $ffff,ind)));
+                                end;
+                                end;
+                   LOC_FLAGS:
+                     begin
+                        ind:=getregister32;
+                        exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,ind)));
+                        exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,ind)));
+                     end
+                else { else outer case }
+                   begin
+                      del_reference(p^.right^.location.reference);
+                           ind:=getregister32;
+
+                      exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+                        newreference(p^.right^.location.reference),ind)));
+
+                           {Booleans are stored in an 8 bit memory location, so
+                           the use of MOVL is not correct.}
+                      case p^.right^.resulttype^.size of
+                        1: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
+                          $ff,ind)));
+                        2: exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
+                          $ffff,ind)));
+                      end; { end case }
+                      end; { end else begin }
+              end;
+
+              { produce possible range check code: }
+              if cs_rangechecking in aktswitches  then
+                begin
+                   if p^.left^.resulttype^.deftype=arraydef then
+                     begin
+                        new(hp);
+                        reset_reference(hp^);
+                        parraydef(p^.left^.resulttype)^.genrangecheck;
+                        hp^.symbol:=stringdup('R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr));
+                        emit_bounds_check(hp^,ind);
+                     end;
+                end;
+
+           { ------------------------ HANDLE INDEXING ----------------------- }
+           { In Motorola 680x0 mode, displacement can only be of 64K max.     }
+           { Therefore instead of doing a direct displacement, we must first  }
+           { load the new address into an address register. Therefore the     }
+           { symbol is not used.                                              }
+           if assigned(p^.location.reference.symbol) then
+           begin
+              if p^.location.reference.base <> R_NO then
+               Message(cg_f_secondvecn_base_defined_twice);
+              p^.location.reference.base:=getaddressreg;
+              exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_LEA,S_L,newcsymbol(p^.location.reference.symbol^,0),
+                p^.location.reference.base)));
+              stringdispose(p^.location.reference.symbol);
+           end;
+
+              if (p^.location.reference.index=R_NO) then
+                begin
+                   p^.location.reference.index:=ind;
+                   calc_emit_mul;
+               { here we must check for the offset      }
+               { and if out of bounds for the motorola  }
+               { eg: out of signed d8 then reload index }
+               { with correct value.                    }
+               if p^.location.reference.offset > 127 then
+               begin
+                  exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_L,p^.location.reference.offset,ind)));
+                  p^.location.reference.offset := 0;
+               end
+               else
+               if p^.location.reference.offset < -128 then
+               begin
+                  exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,S_L,-p^.location.reference.offset,ind)));
+                  p^.location.reference.offset := 0;
+               end;
+                end
+              else
+                begin
+                   if p^.location.reference.base=R_NO then
+                      begin
+                          case p^.location.reference.scalefactor of
+                       2 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,p^.location.reference.index)));
+                       4 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,p^.location.reference.index)));
+                       8 : exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,3,p^.location.reference.index)));
+                       end;
+                          calc_emit_mul;
+
+                    { we must use address register to put index in base }
+                    { compare with cgi386.pas                           }
+
+                    reg := getaddressreg;
+                    p^.location.reference.base := reg;
+
+                    emit_reg_reg(A_MOVE,S_L,p^.location.reference.index,reg);
+                    ungetregister(p^.location.reference.index);
+
+                    p^.location.reference.index:=ind;
+                 end
+               else
+                 begin
+                    reg := getaddressreg;
+                    exprasmlist^.concat(new(pai68k,op_ref_reg(
+                      A_LEA,S_L,newreference(p^.location.reference),
+                      reg)));
+
+                    ungetregister(p^.location.reference.base);
+                    { the symbol offset is loaded,               }
+                    { so release the symbol name and set symbol  }
+                    { to nil                                     }
+                    stringdispose(p^.location.reference.symbol);
+                    p^.location.reference.offset:=0;
+                    calc_emit_mul;
+                    p^.location.reference.base:=reg;
+                    ungetregister32(p^.location.reference.index);
+                    p^.location.reference.index:=ind;
+                 end;
+               end;
+           end;
+      end;
+
+    { *************** Converting Types **************** }
+
+    { produces if necessary rangecheckcode }
+
+    procedure maybe_rangechecking(p : ptree;p2,p1 : pdef);
+
+      var
+         hp : preference;
+       hregister : tregister;
+       neglabel,poslabel : plabel;
+
+      begin
+         { convert from p2 to p1 }
+         { range check from enums is not made yet !!}
+         { and its probably not easy }
+         if (p1^.deftype<>orddef) or (p2^.deftype<>orddef) then
+           exit;
+           { range checking is different for u32bit }
+           { lets try to generate it allways }
+           if (cs_rangechecking in aktswitches)  and
+             { with $R+ explicit type conversations in TP aren't range checked! }
+             (not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and
+             ((porddef(p1)^.von>porddef(p2)^.von) or
+             (porddef(p1)^.bis<porddef(p2)^.bis) or
+             (porddef(p1)^.typ=u32bit) or
+             (porddef(p2)^.typ=u32bit)) then
+           begin
+              porddef(p1)^.genrangecheck;
+              if porddef(p2)^.typ=u8bit then
+                begin
+                   if (p^.location.loc=LOC_REGISTER) or
+                      (p^.location.loc=LOC_CREGISTER) then
+                     begin
+                         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,p^.location.register,R_D6)));
+                         exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$FF,R_D6)));
+                     end
+                   else
+                     begin
+                         exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference),R_D6)));
+                         exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$FF,R_D6)));
+                     end;
+                   hregister:=R_D6;
+                end
+              else if porddef(p2)^.typ=s8bit then
+                begin
+                   if (p^.location.loc=LOC_REGISTER) or
+                      (p^.location.loc=LOC_CREGISTER) then
+                     begin
+                         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,p^.location.register,R_D6)));
+                         { byte to long }
+                         if opt_processors = MC68020 then
+                             exprasmlist^.concat(new(pai68k,op_reg(A_EXTB,S_L,R_D6)))
+                         else
+                           begin
+                             exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_W,R_D6)));
+                             exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,R_D6)));
+                           end;
+                     end
+                   else
+                     begin
+                         exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference),R_D6)));
+                         { byte to long }
+                         if opt_processors = MC68020 then
+                             exprasmlist^.concat(new(pai68k,op_reg(A_EXTB,S_L,R_D6)))
+                         else
+                           begin
+                             exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_W,R_D6)));
+                             exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,R_D6)));
+                           end;
+                     end; { end outermost else }
+                   hregister:=R_D6;
+                end
+               { rangechecking for u32bit ?? !!!!!!}
+               { lets try }
+               else if (porddef(p2)^.typ=s32bit) or (porddef(p2)^.typ=u32bit)  then
+                begin
+                   if (p^.location.loc=LOC_REGISTER) or
+                      (p^.location.loc=LOC_CREGISTER) then
+                     hregister:=p^.location.register
+                   else
+                     begin
+                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),R_D6)));
+                        hregister:=R_D6;
+                     end;
+                end
+              { rangechecking for u32bit ?? !!!!!!}
+              else if porddef(p2)^.typ=u16bit then
+                begin
+                   if (p^.location.loc=LOC_REGISTER) or
+                      (p^.location.loc=LOC_CREGISTER) then
+                     exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,p^.location.register,R_D6)))
+                   else
+                     exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),R_D6)));
+                   { unisgned extend }
+                   exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$FFFF,R_D6)));
+                   hregister:=R_D6;
+                end
+              else if porddef(p2)^.typ=s16bit then
+                begin
+                   if (p^.location.loc=LOC_REGISTER) or
+                      (p^.location.loc=LOC_CREGISTER) then
+                     exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,p^.location.register,R_D6)))
+                   else
+                     exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),R_D6)));
+                   { sign extend }
+                   exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,R_D6)));
+                   hregister:=R_D6;
+                end
+              else internalerror(6);
+              new(hp);
+              reset_reference(hp^);
+              hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr));
+              if porddef(p1)^.von>porddef(p1)^.bis then
+                begin
+                   getlabel(neglabel);
+                   getlabel(poslabel);
+                   exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,hregister)));
+                   emitl(A_BLT,neglabel);
+                end;
+              emit_bounds_check(hp^,hregister);
+              if porddef(p1)^.von>porddef(p1)^.bis then
+                begin
+                   new(hp);
+                   reset_reference(hp^);
+                   hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr+1));
+                   emitl(A_JMP,poslabel);
+                   emitl(A_LABEL,neglabel);
+                   emit_bounds_check(hp^,hregister);
+                   emitl(A_LABEL,poslabel);
+                end;
+           end;
+      end;
+
+    type
+       tsecondconvproc = procedure(p,hp : ptree;convtyp : tconverttype);
+
+     procedure second_nothing(p,hp : ptree;convtyp : tconverttype);
+
+       begin
+       end;
+
+
+
+    procedure second_only_rangecheck(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         maybe_rangechecking(p,hp^.resulttype,p^.resulttype);
+      end;
+
+    procedure second_bigger(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         hregister : tregister;
+         opsize : topsize;
+         op : tasmop;
+         is_register : boolean;
+
+      begin
+         is_register:=p^.left^.location.loc=LOC_REGISTER;
+           if not(is_register) and (p^.left^.location.loc<>LOC_CREGISTER) then
+             begin
+                del_reference(p^.left^.location.reference);
+                { we can do this here as we need no temp inside second_bigger }
+                ungetiftemp(p^.left^.location.reference);
+             end;
+         { this is wrong !!!
+         gives me movl (%eax),%eax
+         for the length(string !!!
+         use only for constant values }
+         {Constanst cannot be loaded into registers using MOVZX!}
+         if (p^.left^.location.loc<>LOC_MEM) or (not p^.left^.location.reference.isintvalue) then
+             case convtyp of
+                     tc_u8bit_2_s32bit,
+                tc_u8bit_2_u32bit,
+                tc_s8bit_2_u32bit,
+                tc_s8bit_2_s16bit,
+                tc_s8bit_2_s32bit,
+                tc_u8bit_2_u16bit,
+                tc_s8bit_2_u16bit,
+                tc_u8bit_2_s16bit: begin
+                                    if is_register then
+                                      hregister := p^.left^.location.register
+                                    else
+                                      hregister := getregister32;
+                                    if is_register then
+                                      emit_reg_reg(A_MOVE,S_B,p^.left^.location.register, hregister)
+                                    else
+                                    begin
+                                      if p^.left^.location.loc = LOC_CREGISTER then
+                                        emit_reg_reg(A_MOVE,S_B,p^.left^.location.register,hregister)
+                                      else
+                                        exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE,S_B,
+                                         newreference(P^.left^.location.reference), hregister)));
+                                    end;
+
+                                    case convtyp of
+                                      tc_u8bit_2_s32bit,
+                                      tc_u8bit_2_u32bit:
+                                                   exprasmlist^.concat(new(pai68k, op_const_reg(
+                                                   A_AND,S_L,$FF,hregister)));
+                                      tc_s8bit_2_u32bit,
+                                      tc_s8bit_2_s32bit:
+                                                  begin
+                                                    if opt_processors = MC68020 then
+                                                      exprasmlist^.concat(new(pai68k,op_reg
+                                                        (A_EXTB,S_L,hregister)))
+                                                    else { else if opt_processors }
+                                                    begin
+                                                    { byte to word }
+                                                      exprasmlist^.concat(new(pai68k,op_reg
+                                                        (A_EXT,S_W,hregister)));
+                                                    { word to long }
+                                                      exprasmlist^.concat(new(pai68k,op_reg
+                                                        (A_EXT,S_L,hregister)));
+                                                    end;
+                                                  end;
+                                      tc_s8bit_2_u16bit,
+                                      tc_u8bit_2_s16bit,
+                                      tc_u8bit_2_u16bit:
+                                                  exprasmlist^.concat(new(pai68k, op_const_reg(
+                                                                A_AND,S_W,$FF,hregister)));
+
+                                      tc_s8bit_2_s16bit:
+                                                  exprasmlist^.concat(new(pai68k, op_reg(
+                                                                A_EXT, S_W, hregister)));
+
+                                    end; { inner case }
+                                   end;
+                tc_u16bit_2_u32bit,
+                tc_u16bit_2_s32bit,
+                tc_s16bit_2_u32bit,
+                tc_s16bit_2_s32bit: begin
+                                     if is_register then
+                                       hregister := p^.left^.location.register
+                                     else
+                                       hregister := getregister32;
+                                     if is_register then
+                                       emit_reg_reg(A_MOVE,S_W,p^.left^.location.register, hregister)
+                                     else
+                                     begin
+                                       if p^.left^.location.loc = LOC_CREGISTER then
+                                         emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,hregister)
+                                       else
+                                         exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE,S_W,
+                                           newreference(P^.left^.location.reference), hregister)));
+                                     end;
+                                     if (convtyp = tc_u16bit_2_s32bit) or
+                                        (convtyp = tc_u16bit_2_u32bit) then
+                                         exprasmlist^.concat(new(pai68k, op_const_reg(
+                                           A_AND, S_L, $ffff, hregister)))
+                                     else { tc_s16bit_2_s32bit }
+                                          { tc_s16bit_2_u32bit }
+                                         exprasmlist^.concat(new(pai68k, op_reg(A_EXT,S_L,
+                                           hregister)));
+                                    end;
+             end { end case }
+         else
+         begin
+             case convtyp of
+                tc_u8bit_2_s32bit,
+                tc_s8bit_2_s32bit,
+                tc_u16bit_2_s32bit,
+                tc_s16bit_2_s32bit,
+            tc_u8bit_2_u32bit,
+            tc_s8bit_2_u32bit,
+            tc_u16bit_2_u32bit,
+            tc_s16bit_2_u32bit:
+
+                    begin
+                        hregister:=getregister32;
+                        op:=A_MOVE;
+                        opsize:=S_L;
+                    end;
+                tc_s8bit_2_u16bit,
+                tc_s8bit_2_s16bit,
+                tc_u8bit_2_s16bit,
+                tc_u8bit_2_u16bit:
+                    begin
+                        hregister:=getregister32;
+                        op:=A_MOVE;
+                        opsize:=S_W;
+                    end;
+             end;
+            if is_register then
+              begin
+                emit_reg_reg(op,opsize,p^.left^.location.register,hregister);
+              end
+            else
+              begin
+                 if p^.left^.location.loc=LOC_CREGISTER then
+                     emit_reg_reg(op,opsize,p^.left^.location.register,hregister)
+                 else exprasmlist^.concat(new(pai68k,op_ref_reg(op,opsize,
+                     newreference(p^.left^.location.reference),hregister)));
+              end;
+         end; { end elseif }
+
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=hregister;
+         maybe_rangechecking(p,p^.left^.resulttype,p^.resulttype);
+      end;
+
+
+
+    procedure second_string_string(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         pushedregs : tpushed;
+
+      begin
+         stringdispose(p^.location.reference.symbol);
+         gettempofsizereference(p^.resulttype^.size,p^.location.reference);
+         del_reference(p^.left^.location.reference);
+         copystring(p^.location.reference,p^.left^.location.reference,pstringdef(p^.resulttype)^.len);
+         ungetiftemp(p^.left^.location.reference);
+      end;
+
+    procedure second_cstring_charpointer(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=getregister32;
+         inc(p^.left^.location.reference.offset);
+         exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
+           R_A0)));
+         emit_reg_reg(A_MOVE, S_L, R_A0, p^.location.register);
+      end;
+
+    procedure second_cchar_charpointer(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         {!!!!}
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=getregister32;
+         inc(p^.left^.location.reference.offset);
+         exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
+           R_A0)));
+         emit_reg_reg(A_MOVE, S_L, R_A0, p^.location.register);
+      end;
+
+    procedure second_string_chararray(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         inc(p^.location.reference.offset);
+      end;
+
+    procedure second_array_to_pointer(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         del_reference(p^.left^.location.reference);
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=getregister32;
+         exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
+           R_A0)));
+         emit_reg_reg(A_MOVE,S_L,R_A0, P^.location.register);
+      end;
+
+    procedure second_pointer_to_array(p,hp : ptree;convtyp : tconverttype);
+
+      var
+       reg: tregister;
+      begin
+         p^.location.loc:=LOC_REFERENCE;
+         clear_reference(p^.location.reference);
+         { here, after doing some arithmetic on the pointer }
+         { we put it back in an address register            }
+         if p^.left^.location.loc=LOC_REGISTER then
+         begin
+           reg := getaddressreg;
+           { move the pointer in a data register back into }
+           { an address register.                          }
+           emit_reg_reg(A_MOVE, S_L, p^.left^.location.register,reg);
+
+           p^.location.reference.base:=reg;
+           ungetregister32(p^.left^.location.register);
+         end
+         else
+           begin
+              if p^.left^.location.loc=LOC_CREGISTER then
+                begin
+                   p^.location.reference.base:=getaddressreg;
+                   emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
+                     p^.location.reference.base);
+                end
+              else
+                begin
+                   del_reference(p^.left^.location.reference);
+                   p^.location.reference.base:=getaddressreg;
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
+                     p^.location.reference.base)));
+                end;
+           end;
+      end;
+
+    { generates the code for the type conversion from an array of char }
+    { to a string                                                        }
+    procedure second_chararray_to_string(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         l : longint;
+
+      begin
+         { this is a type conversion which copies the data, so we can't }
+         { return a reference                                             }
+         p^.location.loc:=LOC_MEM;
+
+         { first get the memory for the string }
+         stringdispose(p^.location.reference.symbol);
+         gettempofsizereference(256,p^.location.reference);
+
+         { calc the length of the array }
+         l:=parraydef(p^.left^.resulttype)^.highrange-
+           parraydef(p^.left^.resulttype)^.lowrange+1;
+
+         if l>255 then
+           Message(sym_e_type_mismatch);
+
+         { write the length }
+           exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,l,
+             newreference(p^.location.reference))));
+
+         { copy to first char of string }
+         inc(p^.location.reference.offset);
+
+         { generates the copy code      }
+         { and we need the source never }
+         concatcopy(p^.left^.location.reference,p^.location.reference,l,true);
+
+         { correct the string location }
+         dec(p^.location.reference.offset);
+      end;
+
+
+(*    procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         stringdispose(p^.location.reference.symbol);
+         gettempofsizereference(256,p^.location.reference);
+         { is it a char const ? }
+         if p^.left^.treetype=ordconstn then
+           exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_W,p^.left^.value*256+1,newreference(p^.location.reference))))
+         else
+           begin
+              { not so elegant (goes better with extra register     }
+              { Here the conversion is done in one shot             }
+              { i.e we convert to a string with a single word which }
+              { will be stored, the length followed by the char     }
+              { This is of course, endian specific.                 }
+              if (p^.left^.location.loc=LOC_REGISTER) or
+                 (p^.left^.location.loc=LOC_CREGISTER) then
+                begin
+                   exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,p^.left^.location.register,R_D6)));
+                   exprasmlist^.concat(new(pai68k, op_const_reg(A_AND, S_W, $FF, R_D6)));
+                   ungetregister32(p^.left^.location.register);
+                end
+              else
+                begin
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.left^.location.reference),R_D6)));
+                   exprasmlist^.concat(new(pai68k, op_const_reg(A_AND, S_W, $FF, R_D6)));
+                   del_reference(p^.left^.location.reference);
+                end;
+              if (opt_processors = MC68020) then
+              { alignment is not a problem on the 68020 and higher processors }
+                Begin
+                  { add length of string to word }
+                  exprasmlist^.concat(new(pai68k,op_const_reg(A_OR,S_W,$0100,R_D6)));
+                  { put back into mem ...        }
+                  exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_W,R_D6,newreference(p^.location.reference))));
+                end
+              else
+                Begin
+                 { alignment can cause problems }
+                  { add length of string to ref }
+                  exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,1,newreference(p^.location.reference))));
+                  if abs(p^.location.reference.offset) >= 1 then
+                    Begin
+                      { temporarily decrease offset }
+                      Inc(p^.location.reference.offset);
+                      exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_B,R_D6,newreference(p^.location.reference))));
+                      Dec(p^.location.reference.offset);
+                      { restore offset }
+                    end
+                  else
+                   Begin
+                     Comment(V_Debug,'SecondChar2String() internal error.');
+                     internalerror(34);
+                  end;
+                end;
+           end;
+      end;*)
+
+    procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         stringdispose(p^.location.reference.symbol);
+         gettempofsizereference(256,p^.location.reference);
+      { call loadstring with correct left and right }
+         p^.right:=p^.left;
+         p^.left:=p;
+         loadstring(p);
+         p^.left:=nil; { reset left tree, which is empty }
+      end;
+
+
+
+
+    procedure second_int_real(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         r : preference;
+        reg:tregister;
+      begin
+        emitloadord2reg(p^.left^.location, porddef(p^.left^.resulttype), R_D6, true);
+        ungetiftemp(p^.left^.location.reference);
+        if porddef(p^.left^.resulttype)^.typ=u32bit then
+           push_int(0);
+
+        emit_reg_reg(A_MOVE, S_L, R_D6, R_SPPUSH);
+        new(r);
+        reset_reference(r^);
+        r^.base := R_SP;
+        { no emulation }
+{           for u32bit a solution would be to push $0 and to load a
++          comp
++           if porddef(p^.left^.resulttype)^.typ=u32bit then
++             exprasmlist^.concat(new(pai386,op_ref(A_FILD,S_Q,r)))
++           else}
+          p^.location.loc := LOC_FPU;
+          { get floating point register. }
+          if (cs_fp_emulation in aktswitches) then
+          begin
+            p^.location.fpureg := getregister32;
+            exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE, S_L, r, R_D0)));
+            emitcall('LONG2SINGLE',true);
+            emit_reg_reg(A_MOVE,S_L,R_D0,p^.location.fpureg);
+          end
+          else
+          begin
+            p^.location.fpureg := getfloatreg;
+            exprasmlist^.concat(new(pai68k, op_ref_reg(A_FMOVE, S_L, r, p^.location.fpureg)))
+          end;
+        if porddef(p^.left^.resulttype)^.typ=u32bit then
+           exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_L,8,R_SP)))
+        else
+        { restore the stack to the previous address }
+           exprasmlist^.concat(new(pai68k, op_const_reg(A_ADDQ, S_L, 4, R_SP)));
+      end;
+
+
+    procedure second_real_fix(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         {hs : string;}
+         rreg : tregister;
+         ref : treference;
+
+      begin
+         rreg:=getregister32;
+         { Are we in a LOC_FPU, if not then use scratch registers }
+         { instead of allocating reserved registers.              }
+         if (p^.left^.location.loc<>LOC_FPU) then
+         begin
+           if (cs_fp_emulation in aktswitches) then
+           begin
+             exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),R_D0)));
+             exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,65536,R_D1)));
+             emitcall('LONGMUL',true);
+             emit_reg_reg(A_MOVE,S_L,R_D0,rreg);
+           end
+           else
+           begin
+             exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,S_L,newreference(p^.left^.location.reference),R_FP0)));
+             exprasmlist^.concat(new(pai68k,op_const_reg(A_FMUL,S_L,65536,R_FP0)));
+             exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,S_L,R_FP0,rreg)));
+           end;
+         end
+         else
+         begin
+           if (cs_fp_emulation in aktswitches) then
+           begin
+             exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0)));
+             exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,65536,R_D1)));
+             emitcall('LONGMUL',true);
+             emit_reg_reg(A_MOVE,S_L,R_D0,rreg);
+           end
+           else
+           begin
+             exprasmlist^.concat(new(pai68k,op_const_reg(A_FMUL,S_L,65536,p^.left^.location.fpureg)));
+             exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,S_L,p^.left^.location.fpureg,rreg)));
+           end;
+         end;
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=rreg;
+      end;
+
+
+    procedure second_float_float(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         case p^.left^.location.loc of
+            LOC_FPU :  begin
+                         { reload }
+                         p^.location.loc := LOC_FPU;
+                         p^.location.fpureg := p^.left^.location.fpureg;
+                       end;
+            LOC_MEM,
+            LOC_REFERENCE : floatload(pfloatdef(p^.left^.resulttype)^.typ,
+                              p^.left^.location.reference,p^.location);
+         end;
+{ ALREADY HANDLED BY FLOATLOAD      }
+{         p^.location.loc:=LOC_FPU; }
+      end;
+
+    procedure second_fix_real(p,hp : ptree;convtyp : tconverttype);
+
+    var
+        startreg : tregister;
+        hl : plabel;
+        r : treference;
+        reg1: tregister;
+        hl1,hl2,hl3,hl4,hl5,hl6,hl7,hl8,hl9: plabel;
+      begin
+         if (p^.left^.location.loc=LOC_REGISTER) or
+            (p^.left^.location.loc=LOC_CREGISTER) then
+           begin
+              startreg:=p^.left^.location.register;
+              ungetregister(startreg);
+              { move d0,d0 is removed by emit_reg_reg }
+              emit_reg_reg(A_MOVE,S_L,startreg,R_D0);
+           end
+         else
+           begin
+              exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(
+                p^.left^.location.reference),R_D0)));
+              del_reference(p^.left^.location.reference);
+              startreg:=R_NO;
+           end;
+
+         reg1 := getregister32;
+
+         { Motorola 68000 equivalent of CDQ     }
+         { we choose d1:d0 pair for quad word   }
+         exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,R_D0)));
+         getlabel(hl1);
+         emitl(A_BPL,hl1);
+         { we copy all bits (-ve number) }
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,$ffffffff,R_D1)));
+         getlabel(hl2);
+         emitl(A_BRA,hl2);
+         emitl(A_LABEL,hl1);
+         exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,R_D0)));
+         emitl(A_LABEL,hl2);
+         { end CDQ }
+
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_EOR,S_L,R_D1,R_D0)));
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,reg1)));
+         getlabel(hl3);
+         emitl(A_BEQ,hl3);
+
+         { Motorola 68000 equivalent of RCL    }
+         getlabel(hl4);
+         emitl(A_BCC,hl4);
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,reg1)));
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_OR,S_L,1,reg1)));
+         getlabel(hl5);
+         emitl(A_BRA,hl5);
+         emitl(A_LABEL,hl4);
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,1,reg1)));
+         emitl(A_LABEL,hl5);
+         { end RCL }
+
+         { Motorola 68000 equivalent of BSR }
+         { save register }
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,R_D6)));
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,31,R_D0)));
+         getlabel(hl6);
+         emitl(A_LABEL,hl6);
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_BTST,S_L,R_D0,R_D1)));
+         getlabel(hl7);
+         emitl(A_BNE,hl7);
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_B,1,R_D0)));
+         emitl(A_BPL,hl6);
+         { restore register }
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D6,R_D0)));
+         emitl(A_LABEL,hl7);
+         { end BSR }
+
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,32,R_D6)));
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_SUB,S_B,R_D1,R_D6)));
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_LSL,S_L,R_D6,R_D0)));
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_ADD,S_W,1007,R_D1)));
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,5,R_D1)));
+
+         { Motorola 68000 equivalent of SHLD }
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,11,R_D6)));
+         { save register }
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D1,R_A0)));
+         getlabel(hl8);
+         emitl(A_LABEL,hl8);
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,R_D1)));
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,reg1)));
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_B,1,R_D6)));
+         emitl(A_BNE,hl8);
+         { restore register }
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A0,R_D1)));
+         { end Motorola equivalent of SHLD }
+
+         { Motorola 68000 equivalent of SHLD }
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,20,R_D6)));
+         { save register }
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,R_A0)));
+         getlabel(hl9);
+         emitl(A_LABEL,hl9);
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,R_D0)));
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_ROXL,S_W,1,reg1)));
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_B,1,R_D6)));
+         emitl(A_BNE,hl9);
+         { restore register }
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A0,R_D0)));
+         { end Motorola equivalent of SHLD }
+
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,20,R_D6)));
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_SUB,S_L,R_D6,R_D0)));
+         emitl(A_LABEL, hl3);
+
+         { create temp values and put on stack }
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,reg1,R_SPPUSH)));
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,R_SPPUSH)));
+
+
+         reset_reference(r);
+         r.base:=R_SP;
+
+         if (cs_fp_emulation in aktswitches) then
+         begin
+           p^.location.loc:=LOC_FPU;
+           p^.location.fpureg := getregister32;
+           exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(r),
+             p^.left^.location.fpureg)))
+         end
+         else
+         begin
+           p^.location.loc:=LOC_FPU;
+           p^.location.fpureg := getfloatreg;
+           exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,S_L,newreference(r),
+               p^.left^.location.fpureg)))
+         end;
+         { clear temporary space }
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_ADDQ,S_L,8,R_SP)));
+         ungetregister32(reg1);
+{ Alreadu handled above...          }
+{         p^.location.loc:=LOC_FPU; }
+      end;
+
+    procedure second_int_fix(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         {hs : string;}
+         hregister : tregister;
+
+      begin
+         if (p^.left^.location.loc=LOC_REGISTER) then
+           hregister:=p^.left^.location.register
+         else if (p^.left^.location.loc=LOC_CREGISTER) then
+           hregister:=getregister32
+         else
+           begin
+              del_reference(p^.left^.location.reference);
+              hregister:=getregister32;
+              case porddef(p^.left^.resulttype)^.typ of
+                s8bit : begin
+                           exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE,S_B,
+                              newreference(p^.left^.location.reference),hregister)));
+                           if opt_processors = MC68020 then
+                              exprasmlist^.concat(new(pai68k, op_reg(A_EXTB,S_L,hregister)))
+                           else
+                            begin
+                              exprasmlist^.concat(new(pai68k, op_reg(A_EXT,S_W,hregister)));
+                              exprasmlist^.concat(new(pai68k, op_reg(A_EXT,S_L,hregister)));
+                            end;
+                        end;
+                u8bit : begin
+                          exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.left^.location.reference),
+                            hregister)));
+                          exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,hregister)));
+                        end;
+                s16bit :begin
+                         exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference),
+                           hregister)));
+                          exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,hregister)));
+                        end;
+                u16bit : begin
+                            exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.left^.location.reference),
+                               hregister)));
+                            exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ffff,hregister)));
+                         end;
+                s32bit,u32bit : exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
+                  hregister)));
+                {!!!! u32bit }
+              end;
+           end;
+         exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVEQ,S_L,16,R_D1)));
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_LSL,S_L,R_D1,hregister)));
+
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=hregister;
+      end;
+
+    procedure second_smaller(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         hregister,destregister : tregister;
+         {opsize : topsize;}
+         ref : boolean;
+         hpp : preference;
+
+      begin
+         { !!!!!!!! Rangechecking }
+         ref:=false;
+         { problems with enums !! }
+         if (cs_rangechecking in aktswitches)  and
+           { with $R+ explicit type conversations in TP aren't range checked! }
+           (not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and
+           (p^.resulttype^.deftype=orddef) and
+           (hp^.resulttype^.deftype=orddef) and
+           ((porddef(p^.resulttype)^.von>porddef(hp^.resulttype)^.von) or
+           (porddef(p^.resulttype)^.bis<porddef(hp^.resulttype)^.bis)) then
+           begin
+              porddef(p^.resulttype)^.genrangecheck;
+              if porddef(hp^.resulttype)^.typ=s32bit then
+                begin
+                   if (p^.location.loc=LOC_REGISTER) or
+                      (p^.location.loc=LOC_CREGISTER) then
+                     hregister:=p^.location.register
+                   else
+                     begin
+                        hregister:=getregister32;
+                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.location.reference),hregister)));
+                     end;
+                end
+              { rangechecking for u32bit ?? !!!!!!}
+              else if porddef(hp^.resulttype)^.typ=u16bit then
+                begin
+                   hregister:=getregister32;
+                   if (p^.location.loc=LOC_REGISTER) or
+                      (p^.location.loc=LOC_CREGISTER) then
+                   begin
+                     exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,p^.location.register,hregister)));
+                   end
+                   else
+                     exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),hregister)));
+                   { clear unused bits  i.e unsigned extend}
+                   exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L, $FFFF, hregister)));
+                end
+              else if porddef(hp^.resulttype)^.typ=s16bit then
+                begin
+                   hregister:=getregister32;
+                   if (p^.location.loc=LOC_REGISTER) or
+                      (p^.location.loc=LOC_CREGISTER) then
+                     exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,p^.location.register,hregister)))
+                   else
+                     exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(p^.location.reference),hregister)));
+                   { sign extend }
+                   exprasmlist^.concat(new(pai68k,op_reg(A_EXT, S_L, hregister)));
+                end
+              else internalerror(6);
+              new(hpp);
+              reset_reference(hpp^);
+              hpp^.symbol:=stringdup('R_'+tostr(porddef(p^.resulttype)^.rangenr));
+
+
+              emit_bounds_check(hpp^, hregister);
+
+              p^.location.loc:=LOC_REGISTER;
+              p^.location.register:=hregister;
+              exit;
+           end;
+         if (p^.left^.location.loc=LOC_REGISTER) or
+           (p^.left^.location.loc=LOC_CREGISTER) then
+           begin
+{ handled by secondpas by called routine ??? }
+{              p^.location.loc:=p^.left^.location.loc; }
+              p^.location.register:=p^.left^.location.register;
+           end;
+      end;
+
+    procedure second_proc_to_procvar(p,hp : ptree;convtyp : tconverttype);far;
+
+    begin
+        secondpass(hp);
+        p^.location.loc:=LOC_REGISTER;
+        del_reference(hp^.location.reference);
+        p^.location.register:=getregister32;
+        exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
+         newreference(hp^.location.reference),R_A0)));
+
+        emit_reg_reg(A_MOVE, S_L, R_A0, P^.location.register);
+    end;
+
+   procedure second_bool_to_byte(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         oldtruelabel,oldfalselabel,hlabel : plabel;
+
+     begin
+         oldtruelabel:=truelabel;
+         oldfalselabel:=falselabel;
+         getlabel(truelabel);
+         getlabel(falselabel);
+        secondpass(hp);
+        p^.location.loc:=LOC_REGISTER;
+        del_reference(hp^.location.reference);
+        p^.location.register:=getregister32;
+        case hp^.location.loc of
+          LOC_MEM,LOC_REFERENCE :
+            exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,
+              newreference(hp^.location.reference),p^.location.register)));
+          LOC_REGISTER,LOC_CREGISTER :
+            exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,
+              hp^.location.register,p^.location.register)));
+           LOC_FLAGS:
+            begin
+               exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[hp^.location.resflags],S_NO,
+                 p^.location.register)))
+            end;
+           LOC_JUMP:
+             begin
+                getlabel(hlabel);
+                emitl(A_LABEL,truelabel);
+                exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,
+                  1,p^.location.register)));
+                emitl(A_JMP,hlabel);
+                emitl(A_LABEL,falselabel);
+                exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_B,p^.location.register)));
+                emitl(A_LABEL,hlabel);
+             end;
+        else
+          internalerror(10060);
+        end;
+         truelabel:=oldtruelabel;
+         falselabel:=oldfalselabel;
+     end;
+
+    procedure secondtypeconv(var p : ptree);
+
+      const
+         secondconvert : array[tc_u8bit_2_s32bit..tc_cchar_charpointer] of
+           tsecondconvproc = (second_bigger,second_only_rangecheck,
+                              second_bigger,second_bigger,second_bigger,
+                              second_smaller,second_smaller,
+                              second_smaller,second_string_string,
+                              second_cstring_charpointer,second_string_chararray,
+                              second_array_to_pointer,second_pointer_to_array,
+                              second_char_to_string,second_bigger,
+                              second_bigger,second_bigger,
+                              second_smaller,second_smaller,
+                              second_smaller,second_smaller,
+                              second_bigger,second_smaller,
+                              second_only_rangecheck,second_bigger,
+                              second_bigger,second_bigger,
+                              second_bigger,second_only_rangecheck,
+                              second_int_real,second_real_fix,
+                              second_fix_real,second_int_fix,second_float_float,
+                       second_chararray_to_string,second_bool_to_byte,
+                       second_proc_to_procvar,
+                       { is constant char to pchar, is done by firstpass }
+                       second_nothing);
+
+      begin
+         { this isn't good coding, I think tc_bool_2_u8bit, shouldn't be }
+         { type conversion (FK)                                        }
+
+         { this is necessary, because second_bool_byte, have to change   }
+         { true- and false label before calling secondpass               }
+         if p^.convtyp<>tc_bool_2_u8bit then
+         begin
+           secondpass(p^.left);
+           set_location(p^.location,p^.left^.location);
+         end;
+         if p^.convtyp<>tc_equal then
+           {the second argument only is for maybe_range_checking !}
+           secondconvert[p^.convtyp](p,p^.left,p^.convtyp)
+      end;
+
+    { save the size of pushed parameter }
+    var
+       pushedparasize : longint;
+
+    procedure secondcallparan(var p : ptree;defcoll : pdefcoll;
+                push_from_left_to_right : boolean);
+
+      var
+         size : longint;
+         stackref : treference;
+         otlabel,hlabel,oflabel : plabel;
+
+         { temporary variables: }
+         tempdeftype : tdeftype;
+         tempreference : treference;
+         r : preference;
+         s : topsize;
+         op : tasmop;
+
+      begin
+         { push from left to right if specified }
+         if push_from_left_to_right and assigned(p^.right) then
+           secondcallparan(p^.right,defcoll^.next,push_from_left_to_right);
+         otlabel:=truelabel;
+         oflabel:=falselabel;
+         getlabel(truelabel);
+         getlabel(falselabel);
+         secondpass(p^.left);
+         { in codegen.handleread.. defcoll^.data is set to nil }
+         if assigned(defcoll^.data) and
+           (defcoll^.data^.deftype=formaldef) then
+           begin
+              { allow @var }
+              if p^.left^.treetype=addrn then
+                begin
+                   { allways a register }
+                   exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_SPPUSH)));
+                   ungetregister32(p^.left^.location.register);
+                end
+              else
+                begin
+                   if (p^.left^.location.loc<>LOC_REFERENCE) and
+                      (p^.left^.location.loc<>LOC_MEM) then
+                     Message(sym_e_type_mismatch)
+                   else
+                     begin
+                        emitpushreferenceaddr(p^.left^.location.reference);
+                        del_reference(p^.left^.location.reference);
+                     end;
+                end;
+              inc(pushedparasize,4);
+           end
+         { handle call by reference parameter }
+         else if (defcoll^.paratyp=vs_var) then
+           begin
+              if (p^.left^.location.loc<>LOC_REFERENCE) then
+                Message(cg_e_var_must_be_reference);
+              { open array ? }
+              { defcoll^.data can be nil for read/write }
+              if assigned(defcoll^.data) and
+                is_open_array(defcoll^.data) then
+                begin
+                   { push high }
+                   if is_open_array(p^.left^.resulttype) then
+                     begin
+                        new(r);
+                        reset_reference(r^);
+                        r^.base:=highframepointer;
+                        r^.offset:=highoffset+4;
+                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_SPPUSH)));
+                     end
+                   else
+                     push_int(parraydef(p^.left^.resulttype)^.highrange-
+                              parraydef(p^.left^.resulttype)^.lowrange);
+                   inc(pushedparasize,4);
+                end;
+              emitpushreferenceaddr(p^.left^.location.reference);
+              del_reference(p^.left^.location.reference);
+              inc(pushedparasize,4);
+           end
+         else
+           begin
+              tempdeftype:=p^.resulttype^.deftype;
+              if tempdeftype=filedef then
+                Message(cg_e_file_must_call_by_reference);
+              if (defcoll^.paratyp=vs_const) and
+                 dont_copy_const_param(p^.resulttype) then
+                begin
+                   emitpushreferenceaddr(p^.left^.location.reference);
+                   del_reference(p^.left^.location.reference);
+                   inc(pushedparasize,4);
+                end
+              else
+                case p^.left^.location.loc of
+                   LOC_REGISTER,
+                   LOC_CREGISTER : begin
+                                             exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
+                                                 p^.left^.location.register,R_SPPUSH)));
+                                             inc(pushedparasize,4);
+                                             ungetregister32(p^.left^.location.register);
+                                     end;
+                   LOC_FPU : begin
+                                        size:=pfloatdef(p^.left^.resulttype)^.size;
+                                        inc(pushedparasize,size);
+                                        exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_L,size,R_SP)));
+                                        new(r);
+                                        reset_reference(r^);
+                                        r^.base:=R_SP;
+                                        s:=getfloatsize(pfloatdef(p^.left^.resulttype)^.typ);
+                                        if (cs_fp_emulation in aktswitches) then
+                                        begin
+                                          { when in emulation mode... }
+                                          { only single supported!!!  }
+                                          exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,
+                                             p^.left^.location.fpureg,r)));
+                                        end
+                                        else
+                                          { convert back from extended to normal type }
+                                          exprasmlist^.concat(new(pai68k,op_reg_ref(A_FMOVE,s,
+                                             p^.left^.location.fpureg,r)));
+                                     end;
+                   LOC_REFERENCE,LOC_MEM :
+                               begin
+                                  tempreference:=p^.left^.location.reference;
+                                  del_reference(p^.left^.location.reference);
+                                  case p^.resulttype^.deftype of
+                                     orddef : begin
+                                                   case porddef(p^.resulttype)^.typ of
+                                                      s32bit,u32bit :
+                                                        begin
+                                                           emit_push_mem(tempreference);
+                                                           inc(pushedparasize,4);
+                                                        end;
+                                                      s8bit,u8bit,uchar,bool8bit,s16bit,u16bit : begin
+                                                          exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
+                                                            newreference(tempreference),R_SPPUSH)));
+                                                          inc(pushedparasize,2);
+                                                      end;
+                                                    end;
+                                              end;
+                                     floatdef : begin
+                                                   case pfloatdef(p^.resulttype)^.typ of
+                                                      f32bit,
+                                                      s32real :
+                                                        begin
+                                                           emit_push_mem(tempreference);
+                                                           inc(pushedparasize,4);
+                                                        end;
+                                                      s64real:
+                                                      {s64bit }
+                                                                begin
+                                                                   inc(tempreference.offset,4);
+                                                                   emit_push_mem(tempreference);
+                                                                   dec(tempreference.offset,4);
+                                                                   emit_push_mem(tempreference);
+                                                                   inc(pushedparasize,8);
+                                                                end;
+{$ifdef use48}
+                                                      s48real : begin
+                                                                end;
+{$endif}
+                                                      s80real : begin
+                                                                    Message(cg_f_extended_cg68k_not_supported);
+{                                                                   inc(tempreference.offset,6);
+                                                                   emit_push_mem(tempreference);
+                                                                   dec(tempreference.offset,4);
+                                                                   emit_push_mem(tempreference);
+                                                                   dec(tempreference.offset,2);
+                                                                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
+                                                                     newreference(tempreference),R_SPPUSH)));
+                                                                   inc(pushedparasize,extended_size);}
+                                                                end;
+                                                   end;
+                                                end;
+                                     pointerdef,procvardef,
+                                         enumdef,classrefdef:  begin
+                                                      emit_push_mem(tempreference);
+                                                      inc(pushedparasize,4);
+                                                   end;
+                                     arraydef,recorddef,stringdef,setdef,objectdef :
+                                                begin
+                                                   if ((p^.resulttype^.deftype=setdef) and
+                                                     (psetdef(p^.resulttype)^.settype=smallset)) then
+                                                     begin
+                                                        emit_push_mem(tempreference);
+                                                        inc(pushedparasize,4);
+                                                     end
+                                                   else
+                                                     begin
+                                                        size:=p^.resulttype^.size;
+
+                                                        { Alignment }
+                                                        {
+                                                        if (size>=4) and ((size and 3)<>0) then
+                                                          inc(size,4-(size and 3))
+                                                        else if (size>=2) and ((size and 1)<>0) then
+                                                          inc(size,2-(size and 1))
+                                                        else
+                                                        if size=1 then size:=2;
+                                                        }
+                                                        { create stack space }
+                                                        if (size > 0) and (size < 9) then
+                                                            exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_L,size,R_SP)))
+                                                        else
+                                                            exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBA,
+                                                              S_L,size,R_SP)));
+                                                        inc(pushedparasize,size);
+                                                        { create stack reference }
+                                                        stackref.symbol := nil;
+                                                        clear_reference(stackref);
+                                                        stackref.base:=R_SP;
+                                                        { produce copy }
+                                                        if p^.resulttype^.deftype=stringdef then
+                                                          begin
+                                                             copystring(stackref,p^.left^.location.reference,
+                                                               pstringdef(p^.resulttype)^.len);
+                                                          end
+                                                        else
+                                                          begin
+                                                             concatcopy(p^.left^.location.reference,
+                                                             stackref,p^.resulttype^.size,true);
+                                                          end;
+                                                     end;
+                                                end;
+                                     else Message(cg_e_illegal_expression);
+                                  end;
+                               end;
+                 LOC_JUMP     : begin
+                                   getlabel(hlabel);
+                                   inc(pushedparasize,2);
+                                   emitl(A_LABEL,truelabel);
+                                   exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,1,R_SPPUSH)));
+                                   emitl(A_JMP,hlabel);
+                                   emitl(A_LABEL,falselabel);
+                                   exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_W,0,R_SPPUSH)));
+                                   emitl(A_LABEL,hlabel);
+                                end;
+                 LOC_FLAGS    : begin
+                                   exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.left^.location.resflags],S_B,
+                                     R_D0)));
+                                   exprasmlist^.concat(new(pai68k,op_reg(A_NEG, S_B, R_D0)));
+                                   exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_W,$ff, R_D0)));
+                                   inc(pushedparasize,2);
+                                   exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,R_D0,R_SPPUSH)));
+                                end;
+                end;
+           end;
+         truelabel:=otlabel;
+         falselabel:=oflabel;
+         { push from right to left }
+         if not push_from_left_to_right and assigned(p^.right) then
+           secondcallparan(p^.right,defcoll^.next,push_from_left_to_right);
+      end;
+
+    procedure secondcalln(var p : ptree);
+
+      var
+         unusedregisters : tregisterset;
+         pushed : tpushed;
+         funcretref : treference;
+         hregister : tregister;
+         oldpushedparasize : longint;
+         { true if a5 must be loaded again after the subroutine }
+         loada5 : boolean;
+         { true if a virtual method must be called directly }
+         no_virtual_call : boolean;
+         { true if we produce a con- or destrutor in a call }
+         is_con_or_destructor : boolean;
+         { true if a constructor is called again }
+         extended_new : boolean;
+         { adress returned from an I/O-error }
+         iolabel : plabel;
+         { lexlevel count }
+         i : longint;
+         { help reference pointer }
+         r : preference;
+         pp,params : ptree;
+         { temp register allocation }
+         reg: tregister;
+         { help reference pointer }
+         ref: preference;
+
+      label
+         dont_call;
+
+      begin
+         extended_new:=false;
+         iolabel:=nil;
+         loada5:=true;
+         no_virtual_call:=false;
+         unusedregisters:=unused;
+         if not assigned(p^.procdefinition) then
+           exit;
+         { only if no proc var }
+         if not(assigned(p^.right)) then
+           is_con_or_destructor:=((p^.procdefinition^.options and poconstructor)<>0)
+             or ((p^.procdefinition^.options and podestructor)<>0);
+         { proc variables destroy all registers }
+         if (p^.right=nil) and
+         { virtual methods too }
+           ((p^.procdefinition^.options and povirtualmethod)=0) then
+           begin
+              if ((p^.procdefinition^.options and poiocheck)<>0)
+                and (cs_iocheck in aktswitches) then
+                begin
+                       getlabel(iolabel);
+                   emitl(A_LABEL,iolabel);
+                end
+              else iolabel:=nil;
+
+              { save all used registers }
+              pushusedregisters(pushed,p^.procdefinition^.usedregisters);
+
+              { give used registers through }
+              usedinproc:=usedinproc or p^.procdefinition^.usedregisters;
+           end
+         else
+           begin
+              pushusedregisters(pushed,$ffff);
+              usedinproc:=$ffff;
+
+              { no IO check for methods and procedure variables }
+              iolabel:=nil;
+           end;
+
+         { generate the code for the parameter and push them }
+         oldpushedparasize:=pushedparasize;
+         pushedparasize:=0;
+         if (p^.resulttype<>pdef(voiddef)) and
+            ret_in_param(p^.resulttype) then
+           begin
+              funcretref.symbol:=nil;
+{$ifdef test_dest_loc}
+              if dest_loc_known and (dest_loc_tree=p) and
+                 (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then
+                begin
+                   funcretref:=dest_loc.reference;
+                   if assigned(dest_loc.reference.symbol) then
+                     funcretref.symbol:=stringdup(dest_loc.reference.symbol^);
+                   in_dest_loc:=true;
+                end
+              else
+{$endif test_dest_loc}
+              gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref);
+           end;
+         if assigned(p^.left) then
+           begin
+              pushedparasize:=0;
+              { be found elsewhere }
+              if assigned(p^.right) then
+                secondcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1,
+                  (p^.procdefinition^.options and poleftright)<>0)
+              else
+                secondcallparan(p^.left,p^.procdefinition^.para1,
+                  (p^.procdefinition^.options and poleftright)<>0);
+           end;
+         params:=p^.left;
+         p^.left:=nil;
+         if ret_in_param(p^.resulttype) then
+           begin
+              emitpushreferenceaddr(funcretref);
+              inc(pushedparasize,4);
+           end;
+         { overloaded operator have no symtable }
+         if (p^.right=nil) then
+           begin
+              { push self }
+              if assigned(p^.symtable) and
+                (p^.symtable^.symtabletype=withsymtable) then
+                begin
+                   { dirty trick to avoid the secondcall below }
+                   p^.methodpointer:=genzeronode(callparan);
+                   p^.methodpointer^.location.loc:=LOC_REGISTER;
+                   p^.methodpointer^.location.register:=R_A5;
+                   { make a reference }
+                   new(r);
+                   reset_reference(r^);
+                   r^.offset:=p^.symtable^.datasize;
+                   r^.base:=procinfo.framepointer;
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_A5)));
+                end;
+
+              { push self }
+              if assigned(p^.symtable) and
+                ((p^.symtable^.symtabletype=objectsymtable) or
+                (p^.symtable^.symtabletype=withsymtable)) then
+                begin
+                   if assigned(p^.methodpointer) then
+                     begin
+                        case p^.methodpointer^.treetype of
+                           typen : begin
+                                      { direct call to inherited method }
+                                      if (p^.procdefinition^.options and poabstractmethod)<>0 then
+                                        begin
+                                           Message(cg_e_cant_call_abstract_method);
+                                           goto dont_call;
+                                        end;
+                                      { generate no virtual call }
+                                      no_virtual_call:=true;
+                             if (p^.symtableprocentry^.properties and sp_static)<>0 then
+                                 begin
+                                    { well lets put the VMT address directly into a5 }
+                                    { it is kind of dirty but that is the simplest    }
+                                    { way to accept virtual static functions (PM)     }
+                                    loada5:=true;
+                                    exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,
+                                      newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_A5)));
+                                    concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
+                                    exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
+                                 end
+                               else
+
+                                  { this is a member call, so A5 isn't modfied }
+                                  loada5:=false;
+
+                               if not(is_con_or_destructor and
+                                  pobjectdef(p^.methodpointer^.resulttype)^.isclass and
+                                  assigned(aktprocsym) and
+                                  ((aktprocsym^.definition^.options and
+                                  (poconstructor or podestructor))<>0)) then
+                                        exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
+                                 { if an inherited con- or destructor should be  }
+                                 { called in a con- or destructor then a warning }
+                                 { will be made                                  }
+                                 { con- and destructors need a pointer to the vmt }
+                                 if is_con_or_destructor and
+                                   ((pobjectdef(p^.methodpointer^.resulttype)^.options and oois_class)=0) and
+                                   assigned(aktprocsym) then
+                                   begin
+                                    if not ((aktprocsym^.definition^.options
+                                      and (poconstructor or podestructor))<>0) then
+                                        Message(cg_w_member_cd_call_from_method);
+                                   end;
+                                      { con- and destructors need a pointer to the vmt }
+                                      if is_con_or_destructor then
+                                        begin
+                                           { classes need the mem ! }
+                                           if ((pobjectdef(p^.methodpointer^.resulttype)^.options and
+
+                                            oois_class)=0) then
+                                             push_int(0)
+                                           else
+                                               begin
+                                                  exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
+                                                   S_L,newcsymbol(pobjectdef(p^.methodpointer^.
+                                                   resulttype)^.vmt_mangledname,0),R_SPPUSH)));
+                                                   concat_external(pobjectdef(p^.methodpointer^.resulttype)^.
+                                                  vmt_mangledname,EXT_NEAR);
+                                               end;
+                                        end;
+                                   end;
+                           hnewn : begin
+                                     { extended syntax of new }
+                                     { A5 must be zero }
+                                     exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,0,R_A5)));
+                                     emit_reg_reg(A_MOVE,S_L,R_A5, R_SPPUSH);
+                                     { insert the vmt }
+                                     exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,
+                                       newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
+                                     concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
+                                              extended_new:=true;
+                                  end;
+                           hdisposen : begin
+                                          secondpass(p^.methodpointer);
+
+                                          { destructor with extended syntax called from dispose }
+                                          { hdisposen always deliver LOC_REFRENZ }
+                                          exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
+                                            newreference(p^.methodpointer^.location.reference),R_A5)));
+                                          del_reference(p^.methodpointer^.location.reference);
+                                          exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
+                                          exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,
+                                            newcsymbol(pobjectdef
+                                               (p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
+                                          concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
+                                       end;
+                           else
+                             begin
+                                { call to a instance member }
+                                if (p^.symtable^.symtabletype<>withsymtable) then
+                                  begin
+                                     secondpass(p^.methodpointer);
+
+
+                                     case p^.methodpointer^.location.loc of
+                                        LOC_REGISTER :
+                                           begin
+                                             ungetregister32(p^.methodpointer^.location.register);
+                                             emit_reg_reg(A_MOVE,S_L,p^.methodpointer^.location.register,R_A5);
+                                           end;
+                                        else
+                                           begin
+                                                 if (p^.methodpointer^.resulttype^.deftype=objectdef) and
+                                                   pobjectdef(p^.methodpointer^.resulttype)^.isclass then
+                                                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+                                                     newreference(p^.methodpointer^.location.reference),R_A5)))
+                                                 else
+                                                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
+                                                     newreference(p^.methodpointer^.location.reference),R_A5)));
+
+                                                del_reference(p^.methodpointer^.location.reference);
+                                             end;
+                                     end;
+                                  end;
+                                    { when calling a class method, we have
+                                      to load ESI with the VMT !
+                                      But that's wrong, if we call a class method via self
+                                    }
+                                    if ((p^.procdefinition^.options and poclassmethod)<>0)
+                                       and not(p^.methodpointer^.treetype=selfn) then
+                                      begin
+                                         { class method needs current VMT }
+                                         new(r);
+                                         reset_reference(r^);
+                                         r^.base:=R_A5;
+                                         exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_A5)));
+                                      end;
+
+                                   exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
+                                   if is_con_or_destructor then
+                                   begin
+                                         { classes don't get a VMT pointer pushed }
+                                         if (p^.methodpointer^.resulttype^.deftype=objectdef) and
+                                           not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) then
+                                           begin
+
+                                            if ((p^.procdefinition^.options and poconstructor)<>0) then
+                                              begin
+                                               { it's no bad idea, to insert the VMT }
+                                                      exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,
+                                               newcsymbol(pobjectdef(
+                                                 p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
+                                               concat_external(pobjectdef(
+                                                 p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
+                                              end
+                                            { destructors haven't to dispose the instance, if this is }
+                                            { a direct call                                           }
+                                            else
+                                              push_int(0);
+                                           end;
+                                  end;
+                             end;
+                        end;
+                     end
+                   else
+                     begin
+                         if ((p^.procdefinition^.options and poclassmethod)<>0) and
+                          not(
+                            assigned(aktprocsym) and
+                            ((aktprocsym^.definition^.options and poclassmethod)<>0)
+                          ) then
+                          begin
+                             { class method needs current VMT }
+                             new(r);
+                             reset_reference(r^);
+                             r^.base:=R_A5;
+                             exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_A5)));
+                          end
+                        else
+                          begin
+                             { member call, A5 isn't modified }
+                             loada5:=false;
+                          end;
+                        exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_SPPUSH)));
+            { but a con- or destructor here would probably almost }
+                        { always be placed wrong }
+                        if is_con_or_destructor then
+                          begin
+                             Message(cg_w_member_cd_call_from_method);
+                             { not insert VMT pointer }                             { VMT-Zeiger nicht eintragen }
+                             push_int(0);
+                          end;
+                     end;
+                end;
+
+              { push base pointer ?}
+              if (lexlevel>1) and assigned(pprocdef(p^.procdefinition)^.parast) and
+            ((p^.procdefinition^.parast^.symtablelevel)>2) then
+                    begin
+                   { if we call a nested function in a method, we must      }
+                   { push also SELF!                                        }
+                   { THAT'S NOT TRUE, we have to load ESI via frame pointer }
+                   { access                                                 }
+                   {
+                     begin
+                        loadesi:=false;
+                        exprasmlist^.concat(new(pai68k,op_reg(A_PUSH,S_L,R_ESI)));
+                     end;
+                   }
+                   if lexlevel=(p^.procdefinition^.parast^.symtablelevel) then
+                     begin
+                        new(r);
+                        reset_reference(r^);
+                        r^.offset:=procinfo.framepointer_offset;
+                        r^.base:=procinfo.framepointer;
+                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_SPPUSH)))
+                     end
+                     { this is only true if the difference is one !!
+                       but it cannot be more !! }
+                   else if lexlevel=(p^.procdefinition^.parast^.symtablelevel)-1 then
+                     begin
+                        exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,procinfo.framepointer,R_SPPUSH)))
+                     end
+                   else if lexlevel>(p^.procdefinition^.parast^.symtablelevel) then
+                     begin
+                        hregister:=getaddressreg;
+                        new(r);
+                        reset_reference(r^);
+                        r^.offset:=procinfo.framepointer_offset;
+                        r^.base:=procinfo.framepointer;
+                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,hregister)));
+                        for i:=(p^.procdefinition^.parast^.symtablelevel) to lexlevel-1 do
+                          begin
+                             new(r);
+                             reset_reference(r^);
+                             {we should get the correct frame_pointer_offset at each level
+                             how can we do this !!! }
+                             r^.offset:=procinfo.framepointer_offset;
+                             r^.base:=hregister;
+                             exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,hregister)));
+                          end;
+                        exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,hregister,R_SPPUSH)));
+                        ungetregister32(hregister);
+                     end
+                   else
+                     internalerror(25000);
+                end;
+
+              { exported methods should be never called direct }
+              if (p^.procdefinition^.options and poexports)<>0 then
+               Message(cg_e_dont_call_exported_direct);
+
+              if ((p^.procdefinition^.options and povirtualmethod)<>0) and
+                 not(no_virtual_call) then
+                begin
+                   { static functions contain the vmt_address in ESI }
+                   { also class methods                              }
+                   if assigned(aktprocsym) then
+                     begin
+                       if ((aktprocsym^.properties and sp_static)<>0) or
+                        ((aktprocsym^.definition^.options and poclassmethod)<>0) or
+                        ((p^.procdefinition^.options and postaticmethod)<>0) or
+                        { A5 is already loaded  }
+                        ((p^.procdefinition^.options and poclassmethod)<>0)then
+                         begin
+                            new(r);
+                            reset_reference(r^);
+                            r^.base:=R_a5;
+                         end
+                       else
+                         begin
+                            new(r);
+                            reset_reference(r^);
+                            r^.base:=R_a5;
+                            exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_a0)));
+                            new(r);
+                            reset_reference(r^);
+                            r^.base:=R_a0;
+                         end;
+                     end
+                   else
+                     begin
+                       new(r);
+                       reset_reference(r^);
+                         r^.base:=R_a5;
+                       exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,R_a0)));
+                       new(r);
+                       reset_reference(r^);
+                       r^.base:=R_a0;
+                     end;
+                  if p^.procdefinition^.extnumber=-1 then
+                        internalerror($Da);
+                  r^.offset:=p^.procdefinition^.extnumber*4+12;
+                  if (cs_rangechecking in aktswitches) then
+                    begin
+                        exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,r^.base,R_SPPUSH)));
+                        emitcall('CHECK_OBJECT',true);
+                    end;
+                  exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,r)));
+                end
+              else
+                emitcall(p^.procdefinition^.mangledname,
+                  p^.symtableproc^.symtabletype=unitsymtable);
+              if ((p^.procdefinition^.options and poclearstack)<>0) then
+                begin
+                   if (pushedparasize > 0) and (pushedparasize < 9) then
+                     { restore the stack, to its initial value }
+                     exprasmlist^.concat(new(pai68k,op_const_reg(A_ADDQ,S_L,pushedparasize,R_SP)))
+                   else
+                     { restore the stack, to its initial value }
+                     exprasmlist^.concat(new(pai68k,op_const_reg(A_ADDA,S_L,pushedparasize,R_SP)));
+                end;
+           end
+         else
+           begin
+              secondpass(p^.right);
+              case p^.right^.location.loc of
+                 LOC_REGISTER,
+                 LOC_CREGISTER : begin
+                                   if p^.right^.location.register in [R_D0..R_D7] then
+                                    begin
+                                       reg := getaddressreg;
+                                       emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,reg);
+                                       new(ref);
+                                       reset_reference(ref^);
+                                       ref^.base := reg;
+                                       exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,ref)));
+                                       ungetregister(reg);
+                                    end
+                                   else
+                                    begin
+                                        new(ref);
+                                        reset_reference(ref^);
+                                        ref^.base := p^.right^.location.register;
+                                        exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,ref)));
+                                    end;
+                                   ungetregister32(p^.right^.location.register);
+                                end
+                 else
+                    begin
+                       exprasmlist^.concat(new(pai68k,op_ref(A_JSR,S_NO,newreference(p^.right^.location.reference))));
+                       del_reference(p^.right^.location.reference);
+                    end;
+              end;
+           end;
+      dont_call:
+         pushedparasize:=oldpushedparasize;
+         unused:=unusedregisters;
+
+         { handle function results }
+         if p^.resulttype<>pdef(voiddef) then
+           begin
+
+              { a contructor could be a function with boolean result }
+              if (p^.right=nil) and
+                 ((p^.procdefinition^.options and poconstructor)<>0) and
+                 { quick'n'dirty check if it is a class or an object }
+                 (p^.resulttype^.deftype=orddef) then
+                begin
+                   p^.location.loc:=LOC_FLAGS;
+                   p^.location.resflags:=F_NE;
+                   if extended_new then
+                     begin
+{$ifdef test_dest_loc}
+                        if dest_loc_known and (dest_loc_tree=p) then
+                          mov_reg_to_dest(p,S_L,R_EAX)
+                        else
+{$endif test_dest_loc}
+                               hregister:=getregister32;
+                               emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
+                               p^.location.register:=hregister;
+                     end;
+                end
+              { structed results are easy to handle.... }
+              else if ret_in_param(p^.resulttype) then
+                begin
+                   p^.location.loc:=LOC_MEM;
+                   stringdispose(p^.location.reference.symbol);
+                   p^.location.reference:=funcretref;
+                end
+              else
+                begin
+                   if (p^.resulttype^.deftype=orddef) then
+                     begin
+                        p^.location.loc:=LOC_REGISTER;
+                  case porddef(p^.resulttype)^.typ of
+                     s32bit,u32bit :
+                        begin
+                             hregister:=getregister32;
+                             emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
+                             p^.location.register:=hregister;
+                        end;
+                     uchar,u8bit,bool8bit,s8bit :
+                        begin
+                            hregister:=getregister32;
+                            emit_reg_reg(A_MOVE,S_B,R_D0,hregister);
+                            p^.location.register:=hregister;
+                        end;
+                     s16bit,u16bit :
+                       begin
+                           hregister:=getregister32;
+                           emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
+                           p^.location.register:=hregister;
+                       end;
+                           else internalerror(7);
+                        end
+                     end
+                   else if (p^.resulttype^.deftype=floatdef) then
+                      case pfloatdef(p^.resulttype)^.typ of
+                           f32bit :
+                              begin
+                                p^.location.loc:=LOC_REGISTER;
+                                hregister:=getregister32;
+                                emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
+                                p^.location.register:=hregister;
+                      end;
+                     s32real,s64bit,s64real,s80real: begin
+                                              if cs_fp_emulation in aktswitches then
+                                              begin
+                                                p^.location.loc:=LOC_FPU;
+                                                      hregister:=getregister32;
+                                                emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
+                                                p^.location.fpureg:=hregister;
+                                              end
+                                              else
+                                              begin
+                                                { TRUE FPU mode }
+                                                p^.location.loc:=LOC_FPU;
+                                                { on exit of function result in R_FP0 }
+                                                p^.location.fpureg:=R_FP0;
+                                              end;
+                                             end;
+                           else
+                      begin
+                              p^.location.loc:=LOC_FPU;
+                              p^.location.fpureg:=R_FP0;
+                      end;
+             end {end case }
+       else
+        begin
+            p^.location.loc:=LOC_REGISTER;
+            hregister:=getregister32;
+            emit_reg_reg(A_MOVE,S_L,R_D0,hregister);
+            p^.location.register:=hregister;
+                end;
+           end;
+         end;
+         { perhaps i/o check ? }
+         if iolabel<>nil then
+           begin
+              exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,newcsymbol(lab2str(iolabel),0),R_SPPUSH)));
+              { this was wrong, probably an error due to diff3
+              emitcall(p^.procdefinition^.mangledname);}
+              emitcall('IOCHECK',true);
+           end;
+
+         { restore registers }
+         popusedregisters(pushed);
+
+         { at last, restore instance pointer (SELF) }
+         if loada5 then
+           maybe_loada5;
+         pp:=params;
+         while assigned(pp) do
+           begin
+             if assigned(pp^.left) then
+               if (pp^.left^.location.loc=LOC_REFERENCE) or
+                 (pp^.left^.location.loc=LOC_MEM) then
+                 ungetiftemp(pp^.left^.location.reference);
+               pp:=pp^.right;
+           end;
+         disposetree(params);
+      end;
+
+    { reverts the parameter list }
+    var nb_para : integer;
+
+    function reversparameter(p : ptree) : ptree;
+
+      var
+         hp1,hp2 : ptree;
+
+      begin
+         hp1:=nil;
+         nb_para := 0;
+         while assigned(p) do
+           begin
+              { pull out }
+              hp2:=p;
+              p:=p^.right;
+              inc(nb_para);
+              { pull in }
+              hp2^.right:=hp1;
+              hp1:=hp2;
+           end;
+         reversparameter:=hp1;
+      end;
+
+
+    procedure secondloadvmt(var p : ptree);
+
+      begin
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=getregister32;
+         exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
+            S_L,newcsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname,0),
+            p^.location.register)));
+      end;
+
+
+    procedure secondinline(var p : ptree);
+    const   in2size:array[in_inc_byte..in_dec_dword] of Topsize=
+                    (S_B,S_W,S_L,S_B,S_W,S_L);
+            in2instr:array[in_inc_byte..in_dec_dword] of Tasmop=
+                    (A_ADDQ,A_ADDQ,A_ADDQ,A_SUBQ,A_SUBQ,A_SUBQ);
+            { tfloattype = (f32bit,s32real,s64real,s80real,s64bit); }
+            float_name: array[tfloattype] of string[8]=
+             {   ('FIXED','SINGLE','REAL','EXTENDED','COMP','FIXED'); }
+             {  Since we only support the REAL (SINGLE IEEE) FLOAT    }
+             {  type, here is what we do...                           }
+                ('FIXED','REAL','REAL','REAL','COMP','FIXED');
+      var
+         opsize: topsize;
+         asmop: tasmop;
+
+         aktfile : treference;
+         ft : tfiletype;
+         pushed : tpushed;
+         dummycoll : tdefcoll;
+
+      { produces code for READ(LN) and WRITE(LN) }
+
+      procedure handlereadwrite(doread,callwriteln : boolean);
+
+        procedure loadstream;
+
+          const io:array[0..1] of string[7]=('_OUTPUT','_INPUT');
+          var     r : preference;
+
+          begin
+              new(r);
+              reset_reference(r^);
+              r^.symbol:=stringdup('U_'+upper(target_info.system_unit)+io[byte(doread)]);
+           if assem_need_external_list and not (cs_compilesystem in aktswitches) then
+                 concat_external(r^.symbol^,EXT_NEAR);
+
+              exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,r,R_A0)))
+          end;
+
+        var
+           node,hp : ptree;
+           typedtyp,pararesult : pdef;
+           doflush,has_length : boolean;
+           dummycoll : tdefcoll;
+           iolabel : plabel;
+           npara : longint;
+
+        begin
+           { I/O check }
+           if cs_iocheck in aktswitches then
+             begin
+                getlabel(iolabel);
+                emitl(A_LABEL,iolabel);
+             end
+           else iolabel:=nil;
+           { no automatic call from flush }
+           doflush:=false;
+           { for write of real with the length specified }
+           has_length:=false;
+           hp:=nil;
+           { reserve temporary pointer to data variable }
+             aktfile.symbol:=nil;
+           gettempofsizereference(4,aktfile);
+           { first state text data }
+           ft:=ft_text;
+           { and state a parameter ? }
+           if p^.left=nil then
+             begin
+                { state screen address}
+                doflush:=true;
+                { the following instructions are for "writeln;" }
+                loadstream;
+                { save @Dateivarible in temporary variable }
+                exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A0,newreference(aktfile))));
+             end
+           else
+             begin
+                { revers paramters }
+                node:=reversparameter(p^.left);
+
+                p^.left := node;
+                npara := nb_para;
+                { calculate data variable }
+                { is first parameter a file type ? }
+                if node^.left^.resulttype^.deftype=filedef then
+                  begin
+                     ft:=pfiledef(node^.left^.resulttype)^.filetype;
+                     if ft=ft_typed then
+                       typedtyp:=pfiledef(node^.left^.resulttype)^.typed_as;
+
+                     secondpass(node^.left);
+                     if codegenerror then
+                       exit;
+
+                     { save reference in temporary variables }                     { reference in tempor„re Variable retten }
+                     if node^.left^.location.loc<>LOC_REFERENCE then
+                       begin
+                          Message(cg_e_illegal_expression);
+                          exit;
+                       end;
+
+                     exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_A0)));
+
+                     { skip to the next parameter }
+                     node:=node^.right;
+                  end
+                else
+                  begin
+                     { if we write to stdout/in then flush after the write(ln) }
+                     doflush:=true;
+                     loadstream;
+                  end;
+
+                { save @Dateivarible in temporary variable }
+                exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A0,newreference(aktfile))));
+                if doread then
+                  { parameter by READ gives call by reference }
+                  dummycoll.paratyp:=vs_var
+                  { an WRITE Call by "Const" }
+                else dummycoll.paratyp:=vs_const;
+
+                { because of secondcallparan, which otherwise attaches }
+                if ft=ft_typed then
+                  begin
+                    { this is to avoid copy of simple const parameters }
+                    dummycoll.data:=new(pformaldef,init);
+                     { use var for write also }
+                     { avoids problems with const passed by value }
+                     { but will not accept untyped const }
+                     { dummycoll.paratyp:=vs_var; }
+                  end
+                else
+                  { I think, this isn't a good solution (FK) }
+                  dummycoll.data:=nil;
+
+                while assigned(node) do
+                  begin
+                     pushusedregisters(pushed,$ffff);
+                     hp:=node;
+                          node:=node^.right;
+                     hp^.right:=nil;
+                     if hp^.is_colon_para then
+                       Message(parser_e_illegal_colon_qualifier);
+                     if hp^.is_colon_para then
+                       Message(parser_e_illegal_colon_qualifier);
+                     if ft=ft_typed then
+                       never_copy_const_param:=true;
+                     secondcallparan(hp,@dummycoll,false);
+                     if ft=ft_typed then
+                       never_copy_const_param:=false;
+                     hp^.right:=node;
+                          if codegenerror then
+                       exit;
+
+                     emit_push_mem(aktfile);
+                          if (ft=ft_typed) then
+                       begin
+                            { OK let's try this }
+                            { first we must only allow the right type }
+                            { we have to call blockread or blockwrite }
+                                   { but the real problem is that            }
+                            { reset and rewrite should have set       }
+                            { the type size                           }
+                                   { as recordsize for that file !!!!        }
+                            { how can we make that                    }
+                            { I think that is only possible by adding }
+                            { reset and rewrite to the inline list a call        }
+                                   { allways read only one record by element }
+                            push_int(typedtyp^.size);
+                            if doread then
+                                     emitcall('TYPED_READ',true)
+                                else
+                                     emitcall('TYPED_WRITE',true)
+                          {!!!!!!!}
+                       end
+                     else
+                       begin
+                          { save current position }
+                          pararesult:=hp^.left^.resulttype;
+                          { handle possible field width  }
+                          { of course only for write(ln) }
+                          if not doread then
+                                 begin
+                                { handle total width parameter }
+                               if assigned(node) and node^.is_colon_para then
+                                 begin
+                                    hp:=node;
+                                    node:=node^.right;
+                                    hp^.right:=nil;
+                                             secondcallparan(hp,@dummycoll,false);
+                                    hp^.right:=node;
+                                             if codegenerror then
+                                      exit;
+                                    has_length:=true;
+                                 end
+                               else
+                               if pararesult^.deftype<>floatdef then
+                                 push_int(0)
+                               else
+                                 push_int(-32767);
+                              { a second colon para for a float ? }
+                              if assigned(node) and node^.is_colon_para then
+                                      begin
+                                    hp:=node;
+                                    node:=node^.right;
+                                             hp^.right:=nil;
+                                    secondcallparan(hp,@dummycoll,false);
+                                             hp^.right:=node;
+                                    if pararesult^.deftype<>floatdef then
+                                     Message(parser_e_illegal_colon_qualifier);
+                                    if codegenerror then
+                                      exit;
+                              end
+                                     else
+                              begin
+                                if hp^.left^.resulttype^.deftype=floatdef then
+                                  push_int(-1);
+                              end;
+                            end;
+                          case pararesult^.deftype of
+                              stringdef : begin
+                                            if doread then
+                                              emitcall('READ_TEXT_STRING',true)
+                                            else
+                                              begin
+                                                 emitcall('WRITE_TEXT_STRING',true);
+                                      {ungetiftemp(hp^.left^.location.reference);}
+                                   end;
+                                         end;
+                             pointerdef : begin
+                                             if is_equal(ppointerdef(pararesult)^.definition,cchardef) then
+                                               begin
+                                                  if doread then
+                                                    emitcall('READ_TEXT_PCHAR_AS_POINTER',true)
+                                                  else
+                                                    emitcall('WRITE_TEXT_PCHAR_AS_POINTER',true);
+                                               end
+                                             else Message(parser_e_illegal_parameter_list);
+                                          end;
+                             arraydef : begin
+                                           if (parraydef(pararesult)^.lowrange=0)
+                                             and is_equal(parraydef(pararesult)^.definition,cchardef) then
+                                             begin
+                                                if doread then
+                                                    emitcall('READ_TEXT_PCHAR_AS_ARRAY',true)
+                                                else
+                                                    emitcall('WRITE_TEXT_PCHAR_AS_ARRAY',true);
+                                             end
+                                           else Message(parser_e_illegal_parameter_list);
+                                        end;
+                      floatdef : begin
+                                      if doread then
+                                          emitcall('READ_TEXT_REAL',true)
+                                      else
+                                          emitcall('WRITE_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true);
+                                 end;
+                      orddef : begin
+                                case porddef(pararesult)^.typ of
+                                   u8bit : if doread then
+                                                emitcall('READ_TEXT_BYTE',true);
+                                   s8bit : if doread then
+                                                emitcall('READ_TEXT_SHORTINT',true);
+                                   u16bit : if doread then
+                                                emitcall('READ_TEXT_WORD',true);
+                                   s16bit : if doread then
+                                                emitcall('READ_TEXT_INTEGER',true);
+                                   s32bit : if doread then
+                                                emitcall('READ_TEXT_LONGINT',true)
+                                            else
+                                                emitcall('WRITE_TEXT_LONGINT',true);
+                                   u32bit : if doread then
+                                                emitcall('READ_TEXT_CARDINAL',true)
+                                            else
+                                                emitcall('WRITE_TEXT_CARDINAL',true);
+                                   uchar : if doread then
+                                                emitcall('READ_TEXT_CHAR',true)
+                                           else
+                                                emitcall('WRITE_TEXT_CHAR',true);
+                                   bool8bit : if  doread then
+                                               { emitcall('READ_TEXT_BOOLEAN',true) }
+                                                 Message(parser_e_illegal_parameter_list)
+                                              else
+                                                 emitcall('WRITE_TEXT_BOOLEAN',true);
+                                   else Message(parser_e_illegal_parameter_list);
+                                end;
+                             end;
+                             else Message(parser_e_illegal_parameter_list);
+                          end;
+                       end;
+                     { load A5 in methods again }
+                     popusedregisters(pushed);
+                     maybe_loada5;
+                  end;
+             end;
+           if callwriteln then
+             begin
+                pushusedregisters(pushed,$ffff);
+                emit_push_mem(aktfile);
+                { pushexceptlabel; }
+                if ft<>ft_text then
+                  Message(parser_e_illegal_parameter_list);
+                     emitcall('WRITELN_TEXT',true);
+                     popusedregisters(pushed);
+                     maybe_loada5;
+                 end;
+           if doflush and not(doread) then
+             begin
+               pushusedregisters(pushed,$ffff);
+               { pushexceptlabel; }
+               emitcall('FLUSH_STDOUT',true);
+               popusedregisters(pushed);
+               maybe_loada5;
+             end;
+           if iolabel<>nil then
+             begin
+                { registers are saved in the procedure }
+                exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,S_L,newcsymbol(lab2str(iolabel),0),R_SPPUSH)));
+                emitcall('IOCHECK',true);
+             end;
+           ungetiftemp(aktfile);
+           if assigned(p^.left) then
+             begin
+                p^.left:=reversparameter(p^.left);
+                if npara<>nb_para then
+                 Message(cg_f_internal_error_in_secondinline);
+                hp:=p^.left;
+                while assigned(hp) do
+                  begin
+                     if assigned(hp^.left) then
+                       if (hp^.left^.location.loc=LOC_REFERENCE) or
+                         (hp^.left^.location.loc=LOC_MEM) then
+                         ungetiftemp(hp^.left^.location.reference);
+                     hp:=hp^.right;
+                  end;
+            end;
+        end;
+
+      procedure handle_str;
+
+        var
+           hp,node,lentree,paratree : ptree;
+           dummycoll : tdefcoll;
+           is_real,has_length : boolean;
+           real_type : byte;
+
+          begin
+           pushusedregisters(pushed,$ffff);
+           node:=p^.left;
+           is_real:=false;
+           has_length:=false;
+           while assigned(node^.right) do node:=node^.right;
+           { if a real parameter somewhere then call REALSTR }
+           if (node^.left^.resulttype^.deftype=floatdef) then
+             is_real:=true;
+
+           node:=p^.left;
+           { we have at least two args }
+           { with at max 2 colon_para in between }
+
+           { first arg longint or float }
+           hp:=node;
+           node:=node^.right;
+           hp^.right:=nil;
+           dummycoll.data:=hp^.resulttype;
+           { string arg }
+
+           dummycoll.paratyp:=vs_var;
+           secondcallparan(hp,@dummycoll,false);
+           if codegenerror then
+             exit;
+
+           dummycoll.paratyp:=vs_const;
+           { second arg }
+           hp:=node;
+           node:=node^.right;
+           hp^.right:=nil;
+           { frac  para }
+           if hp^.is_colon_para and assigned(node) and
+              node^.is_colon_para then
+             begin
+                dummycoll.data:=hp^.resulttype;
+                secondcallparan(hp,@dummycoll,false);
+                if codegenerror then
+                  exit;
+                hp:=node;
+                node:=node^.right;
+                hp^.right:=nil;
+                has_length:=true;
+             end
+           else
+             if is_real then
+             push_int(-1);
+
+           { third arg, length only if is_real }
+           if hp^.is_colon_para then
+             begin
+                dummycoll.data:=hp^.resulttype;
+                secondcallparan(hp,@dummycoll,false);
+                if codegenerror then
+                  exit;
+                hp:=node;
+                node:=node^.right;
+                hp^.right:=nil;
+             end
+           else
+             if is_real then
+               push_int(-32767)
+             else
+               push_int(-1);
+
+           { last arg longint or real }
+           secondcallparan(hp,@dummycoll,false);
+           if codegenerror then
+             exit;
+
+           if is_real then
+             emitcall('STR_'+float_name[pfloatdef(hp^.resulttype)^.typ],true)
+           else if porddef(hp^.resulttype)^.typ=u32bit then
+             emitcall('STR_CARDINAL',true)
+           else
+             emitcall('STR_LONGINT',true);
+           popusedregisters(pushed);
+        end;
+
+      var
+         r : preference;
+
+      begin
+         case p^.inlinenumber of
+            in_lo_word,
+            in_hi_word : begin
+                       secondpass(p^.left);
+                       p^.location.loc:=LOC_REGISTER;
+                       if p^.left^.location.loc<>LOC_REGISTER then
+                         begin
+                            if p^.left^.location.loc=LOC_CREGISTER then
+                              begin
+                                 p^.location.register:=getregister32;
+                                 emit_reg_reg(A_MOVE,S_W,p^.left^.location.register,
+                                   p^.location.register);
+                              end
+                            else
+                              begin
+                                 del_reference(p^.left^.location.reference);
+                                 p^.location.register:=getregister32;
+                                 exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
+                                  newreference(p^.left^.location.reference),
+                                  p^.location.register)));
+                              end;
+                         end
+                       else p^.location.register:=p^.left^.location.register;
+                       if p^.inlinenumber=in_hi_word then
+                         exprasmlist^.concat(new(pai68k,op_const_reg(A_LSR,S_W,8,p^.location.register)));
+                       p^.location.register:=p^.location.register;
+                    end;
+            in_high_x :
+              begin
+                 if is_open_array(p^.left^.resulttype) then
+                   begin
+                      secondpass(p^.left);
+                      del_reference(p^.left^.location.reference);
+                      p^.location.register:=getregister32;
+                      new(r);
+                      reset_reference(r^);
+                      r^.base:=highframepointer;
+                      r^.offset:=highoffset+4;
+                      exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+                        r,p^.location.register)));
+                   end
+              end;
+          in_sizeof_x,
+          in_typeof_x:
+                begin
+                   { load vmt }
+                   if p^.left^.treetype=typen then
+                     begin
+                      p^.location.register:=getregister32;
+                      exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
+                        S_L,newcsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,0),
+                        p^.location.register)));
+                     end
+                   else
+                     begin
+                        secondpass(p^.left);
+                        del_reference(p^.left^.location.reference);
+                        p^.location.loc:=LOC_REGISTER;
+                        p^.location.register:=getregister32;
+                        { load VMT pointer }
+                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+                          newreference(p^.left^.location.reference),
+                          p^.location.register)));
+                     end;
+
+                   { in sizeof load size }
+                   if p^.inlinenumber=in_sizeof_x then
+                     begin
+                        new(r);
+                        reset_reference(r^);
+                        { load the address in A0 }
+                        { because now supposedly p^.location.register is an }
+                        { address.                                          }
+                        emit_reg_reg(A_MOVE, S_L, p^.location.register, R_A0);
+            r^.base:=R_A0;
+                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,
+                          p^.location.register)));
+                     end;
+                end;
+            in_lo_long,
+            in_hi_long : begin
+                       secondpass(p^.left);
+                       p^.location.loc:=LOC_REGISTER;
+                       if p^.left^.location.loc<>LOC_REGISTER then
+                         begin
+                            if p^.left^.location.loc=LOC_CREGISTER then
+                              begin
+                                 p^.location.register:=getregister32;
+                                 emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,
+                                   p^.location.register);
+                              end
+                            else
+                              begin
+                                 del_reference(p^.left^.location.reference);
+                                 p^.location.register:=getregister32;
+                                 exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+                                  newreference(p^.left^.location.reference),
+                                  p^.location.register)));
+                              end;
+                         end
+                       else p^.location.register:=p^.left^.location.register;
+                       if p^.inlinenumber=in_hi_long then
+                         begin
+                           exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVEQ, S_L, 16, R_D1)));
+                           exprasmlist^.concat(new(pai68k,op_reg_reg(A_LSR,S_L,R_D1,p^.location.register)));
+                         end;
+                       p^.location.register:=p^.location.register;
+                    end;
+{We can now comment them out, as they are handled as typecast.
+ Saves an incredible amount of 8 bytes code.
+  I'am not lucky about this, because it's _not_ a type cast (FK) }
+{           in_ord_char,
+            in_chr_byte,}
+            in_length_string : begin
+                       secondpass(p^.left);
+                       set_location(p^.location,p^.left^.location);
+                    end;
+            in_inc_byte..in_dec_dword:
+                begin
+                    secondpass(p^.left);
+                    exprasmlist^.concat(new(pai68k,op_const_ref(in2instr[p^.inlinenumber],
+                     in2size[p^.inlinenumber],1,newreference(p^.left^.location.reference))));
+                    emitoverflowcheck;
+                end;
+            in_pred_x,
+            in_succ_x:
+              begin
+                 secondpass(p^.left);
+                 if p^.inlinenumber=in_pred_x then
+                   asmop:=A_SUB
+                 else
+                   asmop:=A_ADD;
+                 case p^.resulttype^.size of
+                   4 : opsize:=S_L;
+                   2 : opsize:=S_W;
+                   1 : opsize:=S_B;
+                 else
+                    internalerror(10080);
+                 end;
+                 p^.location.loc:=LOC_REGISTER;
+                 if p^.left^.location.loc<>LOC_REGISTER then
+                   begin
+                      p^.location.register:=getregister32;
+                      if p^.left^.location.loc=LOC_CREGISTER then
+                        emit_reg_reg(A_MOVE,opsize,p^.left^.location.register,
+                          p^.location.register)
+                      else
+                      if p^.left^.location.loc=LOC_FLAGS then
+                        exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.left^.location.resflags],S_NO,
+                                  p^.location.register)))
+                      else
+                        begin
+                           del_reference(p^.left^.location.reference);
+                           exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,newreference(p^.left^.location.reference),
+                             p^.location.register)));
+                        end;
+                   end
+                 else p^.location.register:=p^.left^.location.register;
+                 exprasmlist^.concat(new(pai68k,op_reg(asmop,opsize,
+                   p^.location.register)))
+                 { here we should insert bounds check ? }
+                 { and direct call to bounds will crash the program }
+                 { if we are at the limit }
+                 { we could also simply say that pred(first)=first and succ(last)=last }
+                 { could this be usefull I don't think so (PM)
+                 emitoverflowcheck;}
+              end;
+
+        in_assigned_x:
+              begin
+         secondpass(p^.left^.left);
+         p^.location.loc:=LOC_FLAGS;
+         if (p^.left^.left^.location.loc=LOC_REGISTER) or
+           (p^.left^.left^.location.loc=LOC_CREGISTER) then
+           begin
+              exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_L,
+                p^.left^.left^.location.register)));
+              ungetregister32(p^.left^.left^.location.register);
+           end
+         else
+           begin
+              exprasmlist^.concat(new(pai68k,op_ref(A_TST,S_L,
+              newreference(p^.left^.left^.location.reference))));
+              del_reference(p^.left^.left^.location.reference);
+           end;
+         p^.location.resflags:=F_NE;
+          end;
+             in_reset_typedfile,in_rewrite_typedfile :
+               begin
+                  pushusedregisters(pushed,$ffff);
+                  exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,
+                    pfiledef(p^.left^.resulttype)^.typed_as^.size,R_SPPUSH)));
+                  secondload(p^.left);
+                  emitpushreferenceaddr(p^.left^.location.reference);
+                  if p^.inlinenumber=in_reset_typedfile then
+                    emitcall('RESET_TYPED',true)
+                  else
+                    emitcall('REWRITE_TYPED',true);
+                  popusedregisters(pushed);
+               end;
+            in_write_x :
+              handlereadwrite(false,false);
+            in_writeln_x :
+              handlereadwrite(false,true);
+            in_read_x :
+              handlereadwrite(true,false);
+            in_readln_x :
+              begin
+                   handlereadwrite(true,false);
+                   pushusedregisters(pushed,$ffff);
+                   emit_push_mem(aktfile);
+                   { pushexceptlabel; }
+                   if ft<>ft_text then
+                     Message(parser_e_illegal_parameter_list);
+                       emitcall('READLN_TEXT',true);
+                       popusedregisters(pushed);
+                   maybe_loada5;
+                end;
+            in_str_x_string : begin
+                                 handle_str;
+                                 maybe_loada5;
+                              end;
+            else internalerror(9);
+         end;
+      end;
+
+    procedure secondsubscriptn(var p : ptree);
+      var
+       hr: tregister;
+
+      begin
+
+         secondpass(p^.left);
+
+         if codegenerror then
+           exit;
+         { classes must be dereferenced implicit }
+         if (p^.left^.resulttype^.deftype=objectdef) and
+           pobjectdef(p^.left^.resulttype)^.isclass then
+           begin
+             clear_reference(p^.location.reference);
+             case p^.left^.location.loc of
+                LOC_REGISTER:
+                  begin
+                     { move it to an address register...}
+                     hr:=getaddressreg;
+                     emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
+                     p^.location.reference.base:=hr;
+                     { free register }
+                     ungetregister(p^.left^.location.register);
+                  end;
+                LOC_CREGISTER:
+                  begin
+                     { ... and reserve one for the pointer }
+                     hr:=getaddressreg;
+                     emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,hr);
+                       p^.location.reference.base:=hr;
+                  end;
+                else
+                  begin
+                     { free register }
+                     del_reference(p^.left^.location.reference);
+
+                     { ... and reserve one for the pointer }
+                     hr:=getaddressreg;
+                     exprasmlist^.concat(new(pai68k,op_ref_reg(
+                       A_MOVE,S_L,newreference(p^.left^.location.reference),
+                       hr)));
+                     p^.location.reference.base:=hr;
+                  end;
+             end;
+           end
+         else
+           set_location(p^.location,p^.left^.location);
+
+         inc(p^.location.reference.offset,p^.vs^.address);
+      end;
+
+
+    procedure secondselfn(var p : ptree);
+
+      begin
+         clear_reference(p^.location.reference);
+         p^.location.reference.base:=R_A5;
+      end;
+
+    procedure secondhdisposen(var p : ptree);
+
+      begin
+         secondpass(p^.left);
+
+         if codegenerror then
+           exit;
+         clear_reference(p^.location.reference);
+         case p^.left^.location.loc of
+            LOC_REGISTER,
+            LOC_CREGISTER : begin
+                               p^.location.reference.index:=getregister32;
+                               exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
+                                 p^.left^.location.register,
+                                 p^.location.reference.index)));
+                            end;
+            LOC_MEM,LOC_REFERENCE :
+                            begin
+                               del_reference(p^.left^.location.reference);
+                               p^.location.reference.index:=getregister32;
+                               exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.left^.location.reference),
+                                 p^.location.reference.index)));
+                            end;
+         end;
+      end;
+
+    procedure secondhnewn(var p : ptree);
+
+      begin
+      end;
+
+    procedure secondnewn(var p : ptree);
+
+      begin
+         secondpass(p^.left);
+
+         if codegenerror then
+           exit;
+
+         p^.location.register:=p^.left^.location.register;
+      end;
+
+    procedure secondsimplenewdispose(var p : ptree);
+
+      var
+         pushed : tpushed;
+      begin
+         secondpass(p^.left);
+         if codegenerror then
+           exit;
+
+         pushusedregisters(pushed,$ffff);
+         { determines the size of the mem block }
+         push_int(ppointerdef(p^.left^.resulttype)^.definition^.size);
+
+         { push pointer adress }
+         case p^.left^.location.loc of
+            LOC_CREGISTER : exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
+              p^.left^.location.register,R_SPPUSH)));
+            LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference);
+
+         end;
+
+         { call the mem handling procedures }
+         case p^.treetype of
+            simpledisposen :
+                emitcall('FREEMEM',true);
+            simplenewn :
+                emitcall('GETMEM',true);
+         end;
+
+       popusedregisters(pushed);
+         { may be load ESI }
+         maybe_loada5;
+      end;
+
+
+    procedure secondsetcons(var p : ptree);
+
+      var
+         l : plabel;
+         i,smallsetvalue : longint;
+         hp : ptree;
+         href,sref : treference;
+
+      begin
+         { this should be reimplemented for smallsets }
+         { differently  (PM) }
+         { produce constant part }
+         href.symbol := Nil;
+         clear_reference(href);
+         getlabel(l);
+         href.symbol:=stringdup(lab2str(l));
+         stringdispose(p^.location.reference.symbol);
+         datasegment^.concat(new(pai_label,init(l)));
+           {if psetdef(p^.resulttype)=smallset then
+           begin
+              smallsetvalue:=(p^.constset^[3]*256)+p^.constset^[2];
+              smallsetvalue:=((smallset*256+p^.constset^[1])*256+p^.constset^[1];
+              datasegment^.concat(new(pai_const,init_32bit(smallsetvalue)));
+              hp:=p^.left;
+              if assigned(hp) then
+                begin
+                   sref.symbol:=nil;
+                   gettempofsizereference(32,sref);
+                     concatcopy(href,sref,32,false);
+                   while assigned(hp) do
+                     begin
+                        secondpass(hp^.left);
+                        if codegenerror then
+                          exit;
+
+                        pushsetelement(hp^.left);
+                        emitpushreferenceaddr(sref);
+                         register is save in subroutine
+                        emitcall('SET_SET_BYTE',true);
+                        hp:=hp^.right;
+                     end;
+                   p^.location.reference:=sref;
+                end
+              else p^.location.reference:=href;
+           end
+         else    }
+           begin
+           for i:=0 to 31 do
+             datasegment^.concat(new(pai_const,init_8bit(p^.constset^[i])));
+         hp:=p^.left;
+         if assigned(hp) then
+           begin
+              sref.symbol:=nil;
+              gettempofsizereference(32,sref);
+                concatcopy(href,sref,32,false);
+              while assigned(hp) do
+                begin
+                   secondpass(hp^.left);
+                   if codegenerror then
+                     exit;
+
+                   pushsetelement(hp^.left);
+                   emitpushreferenceaddr(sref);
+                   { register is save in subroutine }
+                   emitcall('SET_SET_BYTE',true);
+                   hp:=hp^.right;
+                end;
+              p^.location.reference:=sref;
+           end
+         else p^.location.reference:=href;
+         end;
+      end;
+
+
+    procedure secondcontinuen(var p : ptree);
+
+      begin
+         if aktcontinuelabel<>nil then
+           emitl(A_JMP,aktcontinuelabel)
+         else
+           Message(cg_e_continue_not_allowed);
+      end;
+
+
+{    var
+       hs : string; }
+
+    procedure secondexitn(var p : ptree);
+
+      var
+         is_mem : boolean;
+         {op : tasmop;
+         s : topsize;}
+         otlabel,oflabel : plabel;
+
+      label
+         do_jmp;
+
+      begin
+         if assigned(p^.left) then
+           begin
+              otlabel:=truelabel;
+              oflabel:=falselabel;
+              getlabel(truelabel);
+              getlabel(falselabel);
+              secondpass(p^.left);
+              case p^.left^.location.loc of
+                 LOC_FPU : goto do_jmp;
+                 LOC_MEM,LOC_REFERENCE : is_mem:=true;
+                 LOC_CREGISTER,
+                 LOC_REGISTER : is_mem:=false;
+                 LOC_FLAGS : begin
+                                exprasmlist^.concat(new(pai68k,op_reg(flag_2_set[p^.right^.location.resflags],S_B,R_D0)));
+                                exprasmlist^.concat(new(pai68k,op_reg(A_NEG, S_B, R_D0)));
+                                goto do_jmp;
+                             end;
+                 LOC_JUMP : begin
+                               emitl(A_LABEL,truelabel);
+                               exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_B,1,R_D0)));
+                               emitl(A_JMP,aktexit2label);
+                               exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_B,R_D0)));
+                               goto do_jmp;
+                            end;
+                 else internalerror(2001);
+              end;
+              if (procinfo.retdef^.deftype=orddef) then
+                begin
+                   case porddef(procinfo.retdef)^.typ of
+                      s32bit,u32bit : if is_mem then
+                                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+                                          newreference(p^.left^.location.reference),R_D0)))
+                                      else
+                                        emit_reg_reg(A_MOVE,S_L,
+                                          p^.left^.location.register,R_D0);
+                      u8bit,s8bit,uchar,bool8bit : if is_mem then
+                                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,
+                                          newreference(p^.left^.location.reference),R_D0)))
+                                      else
+                                        emit_reg_reg(A_MOVE,S_B,
+                                          p^.left^.location.register,R_D0);
+                      s16bit,u16bit : if is_mem then
+                                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
+                                          newreference(p^.left^.location.reference),R_D0)))
+                                      else
+                                        emit_reg_reg(A_MOVE,S_W,
+                                          p^.left^.location.register,R_D0);
+                   end;
+                end
+               else
+                 if (procinfo.retdef^.deftype in
+                     [pointerdef,enumdef,procvardef]) then
+                   begin
+                      if is_mem then
+                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+                          newreference(p^.left^.location.reference),R_D0)))
+                      else
+                        exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
+                          p^.left^.location.register,R_D0)));
+                   end
+              else
+                if (procinfo.retdef^.deftype=floatdef) then
+            { floating point return values .... }
+            { single are returned in d0         }
+                  begin
+                     if (pfloatdef(procinfo.retdef)^.typ=f32bit) or
+                   (pfloatdef(procinfo.retdef)^.typ=s32real) then
+                       begin
+                          if is_mem then
+                            exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+                              newreference(p^.left^.location.reference),R_D0)))
+                    else
+                    begin
+                      if pfloatdef(procinfo.retdef)^.typ=f32bit then
+                        emit_reg_reg(A_MOVE,S_L,p^.left^.location.register,R_D0)
+                      else
+                      begin
+                        { single values are in the floating point registers }
+                        if cs_fp_emulation in aktswitches then
+                          emit_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0)
+                        else
+                          exprasmlist^.concat(
+                             new(pai68k,op_reg_reg(A_FMOVE,S_S,p^.left^.location.fpureg,R_D0)));
+                      end;
+                    end;
+                  end
+                  else
+                    { this is only possible in real non emulation mode }
+                    { LOC_MEM,LOC_REFERENCE }
+                    if is_mem then
+                    begin
+                          exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,
+                             getfloatsize(pfloatdef(procinfo.retdef)^.typ),newreference(p^.left^.location.reference),R_FP0)));
+                    end
+                    else
+                    { LOC_FPU }
+                    begin
+                          { convert from extended to correct type }
+                          { when storing                          }
+                          exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,
+                             getfloatsize(pfloatdef(procinfo.retdef)^.typ),p^.left^.location.fpureg,R_FP0)));
+                    end;
+              end;
+do_jmp:
+              truelabel:=otlabel;
+              falselabel:=oflabel;
+              emitl(A_JMP,aktexit2label);
+           end
+         else
+           begin
+              emitl(A_JMP,aktexitlabel);
+           end;
+      end;
+
+    procedure secondgoto(var p : ptree);
+
+      begin
+         emitl(A_JMP,p^.labelnr);
+      end;
+
+    procedure secondlabel(var p : ptree);
+
+      begin
+         emitl(A_LABEL,p^.labelnr);
+         cleartempgen;
+         secondpass(p^.left);
+      end;
+
+    procedure secondasm(var p : ptree);
+
+      begin
+         exprasmlist^.concatlist(p^.p_asm);
+      end;
+
+    procedure secondcase(var p : ptree);
+
+      var
+         with_sign : boolean;
+         opsize : topsize;
+         jmp_gt,jmp_le,jmp_lee : tasmop;
+         hp : ptree;
+         { register with case expression }
+         hregister : tregister;
+         endlabel,elselabel : plabel;
+
+         { true, if we can omit the range check of the jump table }
+         jumptable_no_range : boolean;
+
+      procedure gentreejmp(p : pcaserecord);
+
+        var
+           lesslabel,greaterlabel : plabel;
+
+      begin
+         emitl(A_LABEL,p^._at);
+         { calculate labels for left and right }
+         if (p^.less=nil) then
+           lesslabel:=elselabel
+         else
+           lesslabel:=p^.less^._at;
+         if (p^.greater=nil) then
+           greaterlabel:=elselabel
+         else
+           greaterlabel:=p^.greater^._at;
+           { calculate labels for left and right }
+         { no range label: }
+         if p^._low=p^._high then
+           begin
+              exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^._low,hregister)));
+              if greaterlabel=lesslabel then
+                begin
+                   emitl(A_BNE,lesslabel);
+                end
+              else
+                begin
+                   emitl(jmp_le,lesslabel);
+                   emitl(jmp_gt,greaterlabel);
+                end;
+              emitl(A_JMP,p^.statement);
+           end
+         else
+           begin
+              exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^._low,hregister)));
+              emitl(jmp_le,lesslabel);
+              exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^._high,hregister)));
+              emitl(jmp_gt,greaterlabel);
+              emitl(A_JMP,p^.statement);
+           end;
+         if assigned(p^.less) then
+           gentreejmp(p^.less);
+         if assigned(p^.greater) then
+           gentreejmp(p^.greater);
+      end;
+
+      procedure genlinearlist(hp : pcaserecord);
+
+        var
+           first : boolean;
+           last : longint;
+
+        procedure genitem(t : pcaserecord);
+
+          begin
+             if assigned(t^.less) then
+               genitem(t^.less);
+             if t^._low=t^._high then
+               begin
+                  if (t^._low-last > 0) and (t^._low-last < 9) then
+                     exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,opsize,t^._low-last,hregister)))
+                  else
+                  if (t^._low-last = 0) then
+                     exprasmlist^.concat(new(pai68k,op_reg(A_TST,opsize,hregister)))
+                  else
+                     exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._low-last,hregister)));
+                  last:=t^._low;
+
+                  emitl(A_BEQ,t^.statement);
+               end
+             else
+               begin
+                  { it begins with the smallest label, if the value }
+                  { is even smaller then jump immediately to the    }
+                  { ELSE-label                                      }
+                  if first then
+                    begin
+                       if (t^._low-1 > 0) and (t^._low < 9) then
+                          exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,opsize,t^._low-1,hregister)))
+                       else
+                       if t^._low-1=0 then
+                         exprasmlist^.concat(new(pai68k,op_reg(A_TST,opsize,hregister)))
+                       else
+                         exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._low-1,hregister)));
+                       if t^._low = 0 then
+                          emitl(A_BLE,elselabel)
+                       else
+                          emitl(jmp_lee,elselabel);
+                    end
+                  { if there is no unused label between the last and the }
+                  { present label then the lower limit can be checked    }
+                  { immediately. else check the range in between:        }
+                  else if (t^._low-last>1)then
+
+                    begin
+                       if ((t^._low-last-1) > 0) and ((t^._low-last-1) < 9) then
+                         exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,opsize,t^._low-last-1,hregister)))
+                       else
+                         exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._low-last-1,hregister)));
+                       emitl(jmp_lee,elselabel);
+                    end;
+                  exprasmlist^.concat(new(pai68k,op_const_reg(A_SUB,opsize,t^._high-t^._low+1,hregister)));
+                  emitl(jmp_lee,t^.statement);
+
+                  last:=t^._high;
+               end;
+             first:=false;
+             if assigned(t^.greater) then
+               genitem(t^.greater);
+          end;
+
+        var
+           hr : tregister;
+
+        begin
+           { case register is modified by the list evalution }
+           if (p^.left^.location.loc=LOC_CREGISTER) then
+             begin
+                hr:=getregister32;
+             end;
+           last:=0;
+           first:=true;
+           genitem(hp);
+           emitl(A_JMP,elselabel);
+        end;
+
+      procedure genjumptable(hp : pcaserecord;min_,max_ : longint);
+
+        var
+           table : plabel;
+           last : longint;
+           hr : preference;
+
+        procedure genitem(t : pcaserecord);
+
+          var
+             i : longint;
+
+          begin
+             if assigned(t^.less) then
+               genitem(t^.less);
+             { fill possible hole }
+             for i:=last+1 to t^._low-1 do
+               datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
+                 (elselabel)))));
+             for i:=t^._low to t^._high do
+               datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
+                (t^.statement)))));
+              last:=t^._high;
+             if assigned(t^.greater) then
+               genitem(t^.greater);
+          end;
+
+        begin
+           if not(jumptable_no_range) then
+             begin
+                exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,min_,hregister)));
+                { case expr less than min_ => goto elselabel }
+                emitl(jmp_le,elselabel);
+                exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,max_,hregister)));
+                emitl(jmp_gt,elselabel);
+             end;
+           getlabel(table);
+           { extend with sign }
+           if opsize=S_W then
+             begin
+                { word to long - unsigned }
+                exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ffff,hregister)));
+             end
+           else if opsize=S_B then
+             begin
+                { byte to long - unsigned }
+                exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,$ff,hregister)));
+             end;
+           new(hr);
+           reset_reference(hr^);
+           hr^.symbol:=stringdup(lab2str(table));
+           hr^.offset:=(-min_)*4;
+
+           { add scalefactor *4 to index }
+           exprasmlist^.concat(new(pai68k,op_const_reg(A_LSL,S_L,2,hregister)));
+{           hr^.scalefactor:=4; }
+           hr^.base:=getaddressreg;
+           emit_reg_reg(A_MOVE,S_L,hregister,hr^.base);
+           exprasmlist^.concat(new(pai68k,op_ref(A_JMP,S_NO,hr)));
+{          if not(cs_littlesize in aktswitches^ ) then
+             datasegment^.concat(new(pai68k,op_const(A_ALIGN,S_NO,4))); }
+           datasegment^.concat(new(pai_label,init(table)));
+             last:=min_;
+           genitem(hp);
+           if hr^.base <> R_NO then ungetregister(hr^.base);
+           { !!!!!!!
+           if not(cs_littlesize in aktswitches^ ) then
+             exprasmlist^.concat(new(pai68k,op_const(A_ALIGN,S_NO,4)));
+           }
+        end;
+
+      var
+         lv,hv,min_label,max_label,labels : longint;
+         max_linear_list : longint;
+
+      begin
+         getlabel(endlabel);
+         getlabel(elselabel);
+         with_sign:=is_signed(p^.left^.resulttype);
+         if with_sign then
+           begin
+              jmp_gt:=A_BGT;
+              jmp_le:=A_BLT;
+              jmp_lee:=A_BLE;
+           end
+         else
+           begin
+              jmp_gt:=A_BHI;
+              jmp_le:=A_BCS;
+              jmp_lee:=A_BLS;
+           end;
+         cleartempgen;
+         secondpass(p^.left);
+         { determines the size of the operand }
+         { determines the size of the operand }
+         opsize:=bytes2Sxx[p^.left^.resulttype^.size];
+         { copy the case expression to a register }
+         { copy the case expression to a register }
+         case p^.left^.location.loc of
+            LOC_REGISTER,
+            LOC_CREGISTER : hregister:=p^.left^.location.register;
+            LOC_MEM,LOC_REFERENCE : begin
+                                       del_reference(p^.left^.location.reference);
+                                           hregister:=getregister32;
+                                       exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,newreference(
+                                         p^.left^.location.reference),hregister)));
+                                    end;
+            else internalerror(2002);
+         end;
+         { now generate the jumps }
+         if cs_optimize in aktswitches  then
+           begin
+              { procedures are empirically passed on }
+              { consumption can also be calculated   }
+              { but does it pay on the different     }
+              { processors?                          }
+              { moreover can the size only be appro- }
+              { ximated as it is not known if rel8,  }
+              { rel16 or rel32 jumps are used        }
+              min_label:=case_get_min(p^.nodes);
+              max_label:=case_get_max(p^.nodes);
+              labels:=case_count_labels(p^.nodes);
+              { can we omit the range check of the jump table }
+              getrange(p^.left^.resulttype,lv,hv);
+              jumptable_no_range:=(lv=min_label) and (hv=max_label);
+
+              { optimize for size ? }
+              if cs_littlesize in aktswitches  then
+                begin
+                   if (labels<=2) or ((max_label-min_label)>3*labels) then
+                     { a linear list is always smaller than a jump tree }
+                     genlinearlist(p^.nodes)
+                   else
+                     { if the labels less or more a continuum then }
+                     genjumptable(p^.nodes,min_label,max_label);
+                end
+              else
+                begin
+                   if jumptable_no_range then
+                     max_linear_list:=4
+                   else
+                     max_linear_list:=2;
+
+                   if (labels<=max_linear_list) then
+                     genlinearlist(p^.nodes)
+                   else
+                     begin
+                        if ((max_label-min_label)>4*labels) then
+                          begin
+                             if labels>16 then
+                               gentreejmp(p^.nodes)
+                             else
+                               genlinearlist(p^.nodes);
+                          end
+                        else
+                          genjumptable(p^.nodes,min_label,max_label);
+                     end;
+                end;
+           end
+         else
+           { it's always not bad }
+           genlinearlist(p^.nodes);
+
+         { now generate the instructions }
+         hp:=p^.right;
+         while assigned(hp) do
+           begin
+              cleartempgen;
+              secondpass(hp^.right);
+              emitl(A_JMP,endlabel);
+              hp:=hp^.left;
+           end;
+         emitl(A_LABEL,elselabel);
+         { ... and the else block }
+         if assigned(p^.elseblock) then
+           begin
+              cleartempgen;
+              secondpass(p^.elseblock);
+           end;
+         emitl(A_LABEL,endlabel);
+      end;
+
+
+    procedure secondtryexcept(var p : ptree);
+
+      begin
+
+      end;
+
+    procedure secondtryfinally(var p : ptree);
+
+      begin
+      end;
+
+    procedure secondfail(var p : ptree);
+
+      var hp : preference;
+
+      begin
+         {if procinfo.exceptions then
+           aktproccode.concat(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_E'))
+         else }
+         { we should know if the constructor is called with a new or not,
+         how can we do that ???
+         exprasmlist^.concat(new(pai68k,op_csymbol(A_CALL,S_NO,newcsymbol('HELP_DESTRUCTOR',0))));
+         }
+         exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,R_A5)));
+         { also reset to zero in the stack }
+         new(hp);
+         reset_reference(hp^);
+         hp^.offset:=procinfo.ESI_offset;
+         hp^.base:=procinfo.framepointer;
+         exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,R_A5,hp)));
+         exprasmlist^.concat(new(pai_labeled,init(A_JMP,quickexitlabel)));
+      end;
+
+    procedure secondas(var p : ptree);
+
+      var
+         pushed : tpushed;
+
+      begin
+         set_location(p^.location,p^.left^.location);
+         { save all used registers }
+         pushusedregisters(pushed,$ffff);
+         { push the vmt of the class }
+         exprasmlist^.concat(new(pai68k,op_csymbol_reg(A_MOVE,
+           S_L,newcsymbol(pobjectdef(p^.right^.resulttype)^.vmt_mangledname,0),R_SPPUSH)));
+         concat_external(pobjectdef(p^.right^.resulttype)^.vmt_mangledname,EXT_NEAR);
+         emitpushreferenceaddr(p^.location.reference);
+          emitcall('DO_AS',true);
+         popusedregisters(pushed);
+      end;
+
+    procedure secondis(var p : ptree);
+
+      var
+         pushed : tpushed;
+
+      begin
+         { save all used registers }
+         pushusedregisters(pushed,$ffff);
+         secondpass(p^.left);
+         p^.location.loc:=LOC_FLAGS;
+         p^.location.resflags:=F_NE;
+
+         { push instance to check: }
+         case p^.left^.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              begin
+                 exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,
+                   S_L,p^.left^.location.register,R_SPPUSH)));
+                 ungetregister32(p^.left^.location.register);
+              end;
+            LOC_MEM,LOC_REFERENCE:
+              begin
+                 exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,
+                   S_L,newreference(p^.left^.location.reference),R_SPPUSH)));
+                 del_reference(p^.left^.location.reference);
+              end;
+            else internalerror(100);
+         end;
+
+         { generate type checking }
+         secondpass(p^.right);
+         case p^.right^.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              begin
+                 exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,
+                   S_L,p^.right^.location.register,R_SPPUSH)));
+                 ungetregister32(p^.right^.location.register);
+              end;
+            LOC_MEM,LOC_REFERENCE:
+              begin
+                 exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,
+                   S_L,newreference(p^.right^.location.reference),R_SPPUSH)));
+                 del_reference(p^.right^.location.reference);
+              end;
+            else internalerror(100);
+         end;
+         emitcall('DO_IS',true);
+         exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_B,R_D0)));
+         popusedregisters(pushed);
+      end;
+
+    procedure secondwith(var p : ptree);
+
+       var
+          ref : treference;
+          symtable : psymtable;
+          i : longint;
+
+       begin
+          if assigned(p^.left) then
+            begin
+               secondpass(p^.left);
+               ref.symbol:=nil;
+               gettempofsizereference(4,ref);
+               exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,
+                 newreference(p^.left^.location.reference),R_A0)));
+               exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,
+                 R_A0,newreference(ref))));
+               del_reference(p^.left^.location.reference);
+               { the offset relative to (%ebp) is only needed here! }
+               symtable:=p^.withsymtable;
+               for i:=1 to p^.tablecount do
+                 begin
+                    symtable^.datasize:=ref.offset;
+                    symtable:=symtable^.next;
+                 end;
+
+               { p^.right can be optimize out !!! }
+               if p^.right<>nil then
+                 secondpass(p^.right);
+               { clear some stuff }
+               ungetiftemp(ref);
+            end;
+       end;
+
+    procedure secondpass(var p : ptree);
+      const
+           procedures : array[ttreetyp] of secondpassproc =
+               (secondadd,secondadd,secondadd,secondmoddiv,secondadd,
+                secondmoddiv,secondassignment,secondload,secondnothing,
+                secondadd,secondadd,secondadd,secondadd,
+                secondadd,secondadd,secondin,secondadd,
+                secondadd,secondshlshr,secondshlshr,secondadd,
+               secondadd,secondsubscriptn,secondderef,secondaddr,
+             seconddoubleaddr,
+             secondordconst,secondtypeconv,secondcalln,secondnothing,
+             secondrealconst,secondfixconst,secondumminus,
+             secondasm,secondvecn,
+             secondstringconst,secondfuncret,secondselfn,
+             secondnot,secondinline,secondniln,seconderror,
+             secondnothing,secondhnewn,secondhdisposen,secondnewn,
+             secondsimplenewdispose,secondnothing,secondsetcons,secondblockn,
+             secondnothing,secondnothing,secondifn,secondbreakn,
+             secondcontinuen,second_while_repeatn,second_while_repeatn,secondfor,
+             secondexitn,secondwith,secondcase,secondlabel,
+             secondgoto,secondsimplenewdispose,secondtryexcept,secondraise,
+             secondnothing,secondtryfinally,secondis,secondas,seconderror,
+             secondfail,
+             secondnothing,secondloadvmt);
+      var
+         oldcodegenerror : boolean;
+         oldswitches : Tcswitches;
+         oldis : pinputfile;
+         oldnr : longint;
+
+      begin
+         oldcodegenerror:=codegenerror;
+         oldswitches:=aktswitches;
+         oldis:=current_module^.current_inputfile;
+         oldnr:=current_module^.current_inputfile^.line_no;
+
+         codegenerror:=false;
+         current_module^.current_inputfile:=p^.inputfile;
+         current_module^.current_inputfile^.line_no:=p^.line;
+         aktswitches:=p^.pragmas;
+         if not(p^.error) then
+           begin
+              procedures[p^.treetype](p);
+              p^.error:=codegenerror;
+              codegenerror:=codegenerror or oldcodegenerror;
+           end
+         else codegenerror:=true;
+         aktswitches:=oldswitches;
+         current_module^.current_inputfile:=oldis;
+         current_module^.current_inputfile^.line_no:=oldnr;
+      end;
+
+    function do_secondpass(var p : ptree) : boolean;
+
+      begin
+         codegenerror:=false;
+         if not(p^.error) then
+           secondpass(p);
+         do_secondpass:=codegenerror;
+      end;
+
+    var
+       regvars : array[1..maxvarregs] of pvarsym;
+       regvars_para : array[1..maxvarregs] of boolean;
+       regvars_refs : array[1..maxvarregs] of longint;
+       parasym : boolean;
+
+    procedure searchregvars(p : psym);
+
+      var
+         i,j,k : longint;
+
+      begin
+         if (p^.typ=varsym) and (pvarsym(p)^.regable) then
+           begin
+              { walk through all momentary register variables }
+              for i:=1 to maxvarregs do
+                begin
+                   { free register ? }
+                   if regvars[i]=nil then
+                     begin
+                        regvars[i]:=pvarsym(p);
+                        regvars_para[i]:=parasym;
+                        break;
+                     end;
+                   { else throw out a variable ? }
+                   j:=pvarsym(p)^.refs;
+                   { parameter get a less value }
+                   if parasym then
+                     begin
+                        if cs_littlesize in aktswitches  then
+                          dec(j,1)
+                        else
+                          dec(j,100);
+                     end;
+                   if (j>regvars_refs[i]) and (j>0) then
+                     begin
+                        for k:=maxvarregs-1 downto i do
+                          begin
+                             regvars[k+1]:=regvars[k];
+                             regvars_para[k+1]:=regvars_para[k];
+                          end;
+                        { calc the new refs
+                        pvarsym(p)^.refs:=j; }
+                        regvars[i]:=pvarsym(p);
+                        regvars_para[i]:=parasym;
+                        regvars_refs[i]:=j;
+                        break;
+                     end;
+                end;
+           end;
+      end;
+
+    procedure generatecode(var p : ptree);
+
+      var
+         { *pass modifies with every node aktlinenr and current_module^.current_inputfile, }
+         { to constantly contain the right line numbers             }
+         oldis : pinputfile;
+         oldnr,i : longint;
+         regsize : topsize;
+         regi : tregister;
+         hr : preference;
+
+      label
+         nextreg;
+
+      begin
+         cleartempgen;
+         oldis:=current_module^.current_inputfile;
+         oldnr:=current_module^.current_inputfile^.line_no;
+         { when size optimization only count occurrence }
+         if cs_littlesize in aktswitches then
+           t_times:=1
+         else
+         { reference for repetition is 100 }
+           t_times:=100;
+         { clear register count }
+         for regi:=R_D0 to R_A6 do
+           begin
+              reg_pushes[regi]:=0;
+              is_reg_var[regi]:=false;
+           end;
+
+         use_esp_stackframe:=false;
+
+         if not(do_firstpass(p)) then
+           begin
+              { max. optimizations     }
+              { only if no asm is used }
+              if (cs_maxoptimieren in aktswitches) and
+                ((procinfo.flags and pi_uses_asm)=0) then
+                begin
+                   { can we omit the stack frame ? }
+                   { conditions:
+                     1. procedure (not main block)
+                     2. no constructor or destructor
+                     3. no call to other procedures
+                     4. no interrupt handler
+                   }
+                   if assigned(aktprocsym) then
+                     begin
+                      if (aktprocsym^.definition^.options and poconstructor+podestructor+poinline+pointerrupt=0) and
+                       ((procinfo.flags and pi_do_call)=0) and (lexlevel>1) then
+                       begin
+                          { use ESP as frame pointer }
+                          procinfo.framepointer:=R_SP;
+                          use_esp_stackframe:=true;
+
+                          { calc parameter distance new }
+                          dec(procinfo.framepointer_offset,4);
+                          dec(procinfo.ESI_offset,4);
+
+                          dec(procinfo.retoffset,4);
+
+                          dec(procinfo.call_offset,4);
+                          aktprocsym^.definition^.parast^.call_offset:=procinfo.call_offset;
+                       end;
+                          end; { endif assigned }
+                   if (p^.registers32<4) then
+                     begin
+                        for i:=1 to maxvarregs do
+                          regvars[i]:=nil;
+                        parasym:=false;
+{$ifdef tp}
+                        symtablestack^.foreach(searchregvars);
+{$else}
+                        symtablestack^.foreach(@searchregvars);
+{$endif}
+                        { copy parameter into a register ? }
+                        parasym:=true;
+{$ifdef tp}
+                        symtablestack^.next^.foreach(searchregvars);
+{$else}
+                        symtablestack^.next^.foreach(@searchregvars);
+{$endif}
+
+                        { hold needed registers free }
+                        for i:=maxvarregs downto maxvarregs-p^.registers32+1 do
+                          regvars[i]:=nil;
+                        { now assign register }
+                        for i:=1 to maxvarregs do
+                          begin
+                             if assigned(regvars[i]) then
+                               begin
+                                  { it is nonsens, to copy the variable to }
+                                  { a register because we need then much   }
+                                  { pushes ?                               }
+                                  if reg_pushes[varregs[i]]>=regvars[i]^.refs then
+                                    begin
+                                       regvars[i]:=nil;
+                                       goto nextreg;
+                                    end;
+
+                                  { register is no longer available for }
+                                  { expressions                         }
+                                  { search the register which is the most }
+                                  { unused                                }
+                                  usableregs:=usableregs-[varregs[i]];
+                                  is_reg_var[varregs[i]]:=true;
+                                  dec(c_usableregs);
+
+                                  { possibly no 32 bit register are needed }
+                                  if  (regvars[i]^.definition^.deftype=orddef) and
+                                      (
+                                       (porddef(regvars[i]^.definition)^.typ=bool8bit) or
+                                       (porddef(regvars[i]^.definition)^.typ=uchar) or
+                                       (porddef(regvars[i]^.definition)^.typ=u8bit) or
+                                       (porddef(regvars[i]^.definition)^.typ=s8bit)
+                                      ) then
+                                    begin
+                                       regvars[i]^.reg:=varregs[i];
+                                       regsize:=S_B;
+                                    end
+                                  else if  (regvars[i]^.definition^.deftype=orddef) and
+                                      (
+                                       (porddef(regvars[i]^.definition)^.typ=u16bit) or
+                                       (porddef(regvars[i]^.definition)^.typ=s16bit)
+                                      ) then
+                                    begin
+                                       regvars[i]^.reg:=varregs[i];
+                                       regsize:=S_W;
+                                    end
+                                  else
+                                    begin
+                                       regvars[i]^.reg:=varregs[i];
+                                       regsize:=S_L;
+                                    end;
+                                  { parameter must be load }
+                                  if regvars_para[i] then
+                                    begin
+                                       { procinfo is there actual,      }
+                                       { because we can't never be in a }
+                                       { nested procedure               }
+                                       { when loading parameter to reg  }
+                                       new(hr);
+                                       reset_reference(hr^);
+                                       hr^.offset:=pvarsym(regvars[i])^.address+procinfo.call_offset;
+                                       hr^.base:=procinfo.framepointer;
+                                       procinfo.aktentrycode^.concat(new(pai68k,op_ref_reg(A_MOVE,regsize,
+                                         hr,regvars[i]^.reg)));
+                                       unused:=unused - [regvars[i]^.reg];
+                                    end;
+                                  { procedure uses this register }
+                                  usedinproc:=usedinproc or ($800 shr word(varregs[i]));
+                               end;
+                             nextreg:
+                               { dummy }
+                               regsize:=S_W;
+                          end;
+                        if (verbosity and v_debug)=v_debug then
+                          begin
+                             for i:=1 to maxvarregs do
+                               begin
+                                  if assigned(regvars[i]) then
+                                   Message3(cg_d_register_weight,reg2str(regvars[i]^.reg),
+                                           tostr(regvars[i]^.refs),regvars[i]^.name);
+                               end;
+                          end;
+                     end;
+                end;
+              do_secondpass(p);
+
+              { all registers can be used again }
+              { contains both information on Address registers and data registers }
+              { even if they are allocated separately.                            }
+              usableregs:=[R_D0,R_D1,R_D2,R_D3,R_D4,R_D5,R_D6,R_D7,R_A0,R_A1,R_A2,R_A3,R_A4,
+                  R_FP0,R_FP1,R_FP2,R_FP3,R_FP4,R_FP5,R_FP6,R_FP7];
+              c_usableregs:=4;
+           end;
+         procinfo.aktproccode^.concatlist(exprasmlist);
+
+         current_module^.current_inputfile:=oldis;
+         current_module^.current_inputfile^.line_no:=oldnr;
+      end;
+
+end.
+
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:16  root
+  Initial revision
+
+  Revision 1.51  1998/03/22 12:45:37  florian
+    * changes of Carl-Eric to m68k target commit:
+      - wrong nodes because of the new string cg in intel, I had to create
+        this under m68k also ... had to work it out to fix potential alignment
+        problems --> this removes the crash of the m68k compiler.
+      - added absolute addressing in m68k assembler (required for Amiga startup)
+      - fixed alignment problems (because of byte return values, alignment
+        would not be always valid) -- is this ok if i change the offset if odd in
+        setfirsttemp ?? -- it seems ok...
+
+  Revision 1.50  2036/02/07 09:29:32  florian
+    * patch of Carl applied
+
+  Revision 1.49  1998/03/10 16:27:36  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.48  1998/03/10 15:25:31  carl
+    + put back $L switch for debugging
+
+  Revision 1.47  1998/03/10 04:19:24  carl
+    - removed string:=char optimization because would give A LOT of
+  register problems
+
+  Revision 1.46  1998/03/10 01:17:15  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.45  1998/03/09 10:44:33  peter
+    + string='', string<>'', string:='', string:=char optimizes (the first 2
+      were already in cg68k2)
+
+  Revision 1.44  1998/03/06 00:51:57  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.43  1998/03/05 04:37:46  carl
+    + small optimization
+
+  Revision 1.42  1998/03/03 04:13:31  carl
+    - removed generate_xxxx and put them in cga68k
+
+  Revision 1.41  1998/03/03 01:08:17  florian
+    * bug0105 and bug0106 problem solved
+
+  Revision 1.40  1998/03/02 16:25:25  carl
+    * bugfix #95
+
+  Revision 1.39  1998/03/02 01:48:11  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.38  1998/02/25 02:36:29  carl
+    * small bugfix with range checking
+
+  Revision 1.37  1998/02/24 16:49:48  peter
+    * stackframe ommiting generated 'ret $-4'
+    + timer.pp bp7 version
+    * innr.inc are now the same files
+
+  Revision 1.36  1998/02/24 16:42:49  carl
+    + reinstated __EXIT
+
+  Revision 1.35  1998/02/23 02:56:38  carl
+    * bugfix of writing real type values qith m68k target
+
+  Revision 1.34  1998/02/22 23:03:05  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.33  1998/02/22 18:50:12  carl
+    * bugfix of stupid diffs!!!!! Recursive crash fix!
+
+  Revision 1.30  1998/02/19 12:22:29  daniel
+  * Optimized a statement that did pain to my eyes.
+
+  Revision 1.29  1998/02/17 21:20:31  peter
+    + Script unit
+    + __EXIT is called again to exit a program
+    - target_info.link/assembler calls
+    * linking works again for dos
+    * optimized a few filehandling functions
+    * fixed stabs generation for procedures
+
+  Revision 1.28  1998/02/15 21:16:04  peter
+    * all assembler outputs supported by assemblerobject
+    * cleanup with assembleroutputs, better .ascii generation
+    * help_constructor/destructor are now added to the externals
+    - generation of asmresponse is not outputformat depended
+
+  Revision 1.27  1998/02/14 05:06:47  carl
+    + now works with TP with overlays
+
+  Revision 1.26  1998/02/14 01:45:06  peter
+    * more fixes
+    - pmode target is removed
+    - search_as_ld is removed, this is done in the link.pas/assemble.pas
+    + findexe() to search for an executable (linker,assembler,binder)
+
+  Revision 1.25  1998/02/13 10:34:40  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.24  1998/02/12 11:49:45  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.23  1998/02/07 18:00:45  carl
+    * bugfix in secondin (from Peter Vreman a while ago)
+
+  Revision 1.21  1998/02/05 00:58:05  carl
+    + secondas and secondis now work as expected.
+    - moved secondas to cg68k2, otherwise problems with symbols
+
+  Revision 1.20  1998/02/01 19:38:41  florian
+    * bug0029 fixed, Carl please check it !!!
+
+  Revision 1.19  1998/01/24 21:05:41  carl
+    * nested comment bugfix
+
+  Revision 1.18  1998/01/24 00:37:47  florian
+    * small fix for DOM
+
+  Revision 1.17  1998/01/21 21:29:46  florian
+    * some fixes for Delphi classes
+
+  Revision 1.16  1998/01/20 23:51:59  carl
+    * bugfix 74 (FINAL, Pierre's one was incomplete under BP)
+
+  Revision 1.15  1998/01/19 10:25:21  pierre
+    * bug in object function call in main program or unit init fixed
+
+  Revision 1.14  1998/01/16 22:34:23  michael
+  * Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
+    in this compiler :)
+
+  Revision 1.13  1998/01/16 02:18:25  carl
+    * second_char_to_string align problem fix (N/A for MC68020 target)
+
+  Revision 1.12  1998/01/13 23:11:02  florian
+    + class methods
+
+  Revision 1.11  1998/01/11 03:36:14  carl
+  * fixed indexing problem with stack
+  * reference on stack bugfix
+  * second_bigger sign extension bugfix
+  * array scaling bugfix
+  * secondderef bugfix
+  * bugfix with MOVEQ opcode
+  * bugfix of linear list generation
+
+  Revision 1.6  1997/12/10 23:07:12  florian
+  * bugs fixed: 12,38 (also m68k),39,40,41
+  + warning if a system unit is without -Us compiled
+  + warning if a method is virtual and private (was an error)
+  * some indentions changed
+  + factor does a better error recovering (omit some crashes)
+  + problem with @type(x) removed (crashed the compiler)
+
+  Revision 1.5  1997/12/09 13:28:48  carl
+  + added s80 real (will presently stop the compiler though)
+  + renamed some stuff
+  * some bugfixes (can't remember what exactly..)
+
+  Revision 1.4  1997/12/05 14:51:09  carl
+  * bugfix of secondfor
+      cmpreg was never initialized.
+      one of the jump conditionals was wrong (downto would not work)
+
+  Revision 1.3  1997/12/04 14:47:05  carl
+  + updated tov09...
+
+  Revision 1.2  1997/11/28 18:14:20  pierre
+   working version with several bug fixes
+
+  Revision 1.1.1.1  1997/11/27 08:32:51  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
+
+  History (started with version 0.9.0):
+      23th october 1996:
+         + some emit calls replaced (FK)
+      24th october 1996:
+         * for bug fixed (FK)
+      26th october 1996:
+         * english comments (FK)
+       5th november 1996:
+         * new init and terminate code (FK)
+
+      ...... some items missed
+
+      19th september 1997:
+         * a call to a function procedure a;[ C ]; doesn't crash the stack
+           furthermore (FK)
+      22th september 1997:
+         * stack layout for nested procedures in methods modified:
+           ESI is no more pushed (must be loaded via framepointer) (FK)
+
+      27th september 1997:
+        + Start of conversion to motorola MC68000 (CEC)
+      29th september 1997:
+        + Updated to version 0.9.4 of Intel code generator (CEC)
+      3th october 1997:
+        + function second_bool_to_byte for ord(boolean) (PM)
+      4th october 1997: (CEC)
+         + first compilation
+      5th octover 1997:
+          check floating point negate when i can test everything,
+            to see if it makes any sense , according SINGLE_NEG from
+            sozobon, it does not.??
+      8th october 1997:
+        + ord(x) support (FK)
+        + some stuff for typed file support (FK)
+      9 october 1997:
+        + converted code to motorola for v096 (CEC)
+     18 october 1997:
+        +* removed bugs relating to floating point condition codes. (CEC).
+           (in secondadd).
+        + had to put secondadd in another routine to compile in tp. (CEC).
+        + updated second_bool_to_byte,secondtypeconv and secondinline, secondvecn to v097 (CEC)
+        + updated secondload and secondstringconst (merging duplicate strings),secondfor to v95/v97 (CEC).
+        + finally converted second_fix_real (very difficult and untested!). (CEC)
+     23 october 1997:
+        * bugfix of address register in usableregs set. (They were not defined...) (CEC).
+     24 october 1997:
+        * bugfix of scalefactor, allowed unrolled using lsl. (CEC).
+   27th october 1997:
+       + now all general purpose registers are in the unused list, so this fixes problems
+         regarding pushing registers (such as d0) which were actually never used. (CEC)
+       + added secondin (FK) (all credit goes to him).
+       + converted second_real_fix thanks to Daniel Mantione for the information
+         he gave me on the fixed format. Thanks to W. Metzenthen who did WMEmu
+         (which in turn gave me information on the control word of the intel fpu). (CEC)
+   23rd november 1997:
+       + changed second_int_real to apply correct calling conventions of rtl.
+   26th november 1997:
+       + changed secondmoddiv to apply correct calling conventions of rtl
+          and also optimized it a bit.
+
+}
+

compiler/cg68k2.pas

@@ -0,0 +1,1989 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl, Carl Eric Codere
+
+    This unit generates 68000 (or better) assembler from the parse tree
+
+    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.
+
+ ****************************************************************************
+}
+
+{$ifdef tp}
+  {$E+,F+,N+,D+,L+,Y+}
+{$endif}
+Unit Cg68k2;
+
+Interface
+
+    uses
+       objects,verbose,cobjects,systems,globals,tree,
+       symtable,types,strings,pass_1,hcodegen,
+       aasm,m68k,tgen68k,files,cga68k;
+
+      const
+
+       { process condition codes bit definitions }
+       CARRY_FLAG    = $01;
+       OVFL_FLAG     = $02;
+       ZERO_FLAG     = $04;
+       NEG_FLAG      = $08;
+       { to set OR with flags     }
+       { to clear AND (NOT flag)  }
+
+
+    procedure secondadd(var p : ptree);
+    procedure processcc(p: ptree);
+    procedure secondfor(var p : ptree);
+    procedure secondas(var p : ptree);
+    procedure secondraise(var p : ptree);
+    procedure secondin(var p : ptree);
+    procedure secondexpr(var p : ptree);
+    procedure secondblockn(var p : ptree);
+    procedure second_while_repeatn(var p : ptree);
+    procedure secondifn(var p : ptree);
+    procedure secondbreakn(var p : ptree);
+    { copies p a set element on the stack }
+    procedure pushsetelement(var p : ptree);
+
+Implementation
+
+    uses cg68k;
+
+
+    procedure secondadd(var p : ptree);
+
+    { is also being used for xor, and "mul", "sub, or and comparative }
+    { operators                                                       }
+
+      label do_normal;
+      var
+         swapp : ptree;
+         hregister : tregister;
+         pushed,mboverflow,cmpop : boolean;
+         op : tasmop;
+         pushedregs : tpushed;
+         flags : tresflags;
+         otl,ofl : plabel;
+         power : longint;
+         href : treference;
+         opsize : topsize;
+         swapl : tlocation;
+         tmpref: treference;
+         { true, if unsigned types are compared }
+         unsigned : boolean;
+
+          { is_in_dest if the result is put directly into }
+          { the resulting refernce or varregister }
+           { true, if a small set is handled with the longint code }
+          is_set : boolean;
+          is_in_dest : boolean;
+           { true, if for sets subtractions the extra not should generated }
+           extra_not : boolean;
+
+      begin
+         unsigned:=false;
+         is_in_dest := false;
+         extra_not:=false;
+
+         opsize:=S_L;
+
+         { calculate the operator which is more difficult }
+         firstcomplex(p);
+         { handling boolean expressions extra: }
+         if ((p^.left^.resulttype^.deftype=orddef) and
+            (porddef(p^.left^.resulttype)^.typ=bool8bit)) then
+{            ((p^.right^.resulttype^.deftype=orddef) and
+            (porddef(p^.right^.resulttype)^.typ=bool8bit)) then }
+           begin
+              if (p^.treetype=andn) or (p^.treetype=orn) then
+                begin
+                   p^.location.loc:=LOC_JUMP;
+                   cmpop:=false;
+                   case p^.treetype of
+                     andn : begin
+                               otl:=truelabel;
+                               getlabel(truelabel);
+                               secondpass(p^.left);
+                               maketojumpbool(p^.left);
+                               emitl(A_LABEL,truelabel);
+                               truelabel:=otl;
+                            end;
+                     orn : begin
+                              ofl:=falselabel;
+                              getlabel(falselabel);
+                              secondpass(p^.left);
+                              maketojumpbool(p^.left);
+                              emitl(A_LABEL,falselabel);
+                              falselabel:=ofl;
+                           end;
+                     else Message(sym_e_type_mismatch);
+                   end; { end case }
+                  secondpass(p^.right);
+                  maketojumpbool(p^.right);
+                end { endif }
+              else if p^.treetype in [unequaln,equaln,xorn] then
+                begin
+                   opsize:=S_B;
+                   if p^.left^.treetype=ordconstn then
+                     begin
+                        swapp:=p^.right;
+                        p^.right:=p^.left;
+                        p^.left:=swapp;
+                        p^.swaped:=not(p^.swaped);
+                     end;
+                   secondpass(p^.left);
+                   p^.location:=p^.left^.location;
+                   (* register needed *)
+                   pushed:=maybe_push(p^.right^.registers32,p);
+                   secondpass(p^.right);
+                   if pushed then restore(p);
+                   goto do_normal;
+                end { endif }
+              else Message(sym_e_type_mismatch);
+           end { endif }
+         { also handle string operations seperately }
+         else if (p^.left^.resulttype^.deftype=stringdef) then
+           begin
+              { string operations are not commutative }
+              if p^.swaped then
+                begin
+                   swapp:=p^.left;
+                   p^.left:=p^.right;
+                   p^.right:=swapp;
+                   { because of jump being produced at comparison below: }
+                   p^.swaped:=not(p^.swaped);
+                end;
+              case p^.treetype of
+                 addn : begin
+                           cmpop:=false;
+                           secondpass(p^.left);
+                           if (p^.left^.treetype<>addn) then
+                             begin
+                                { can only reference be }
+                                { string in register would be funny    }
+                                { therefore produce a temporary string }
+
+                                { release the registers }
+                                del_reference(p^.left^.location.reference);
+                                gettempofsizereference(256,href);
+                                copystring(href,p^.left^.location.reference,255);
+                                ungetiftemp(p^.left^.location.reference);
+
+                                { does not hurt: }
+                                p^.left^.location.loc:=LOC_MEM;
+                                p^.left^.location.reference:=href;
+                             end;
+
+                           secondpass(p^.right);
+
+                           { on the right we do not need the register anymore too }
+                           del_reference(p^.right^.location.reference);
+                           pushusedregisters(pushedregs,$ffff);
+                           emitpushreferenceaddr(p^.left^.location.reference);
+                           emitpushreferenceaddr(p^.right^.location.reference);
+                           emitcall('STRCONCAT',true);
+                           set_location(p^.location,p^.left^.location);
+                           ungetiftemp(p^.right^.location.reference);
+                           maybe_loada5;
+                           popusedregisters(pushedregs);
+                        end; { this case }
+              ltn,lten,gtn,gten,
+                equaln,unequaln :
+                        begin
+                           secondpass(p^.left);
+                           { are too few registers free? }
+                           pushed:=maybe_push(p^.right^.registers32,p);
+                           secondpass(p^.right);
+                           if pushed then restore(p);
+                           cmpop:=true;
+                           del_reference(p^.right^.location.reference);
+                           del_reference(p^.left^.location.reference);
+                           { generates better code }
+                           { s='' and s<>''        }
+                           if (p^.treetype in [equaln,unequaln]) and
+                             (
+                               ((p^.left^.treetype=stringconstn) and
+                                (p^.left^.values^='')) or
+                               ((p^.right^.treetype=stringconstn) and
+                                (p^.right^.values^=''))
+                             ) then
+                             begin
+                                { only one node can be stringconstn }
+                                { else pass 1 would have evaluted   }
+                                { this node                         }
+                                if p^.left^.treetype=stringconstn then
+                                  exprasmlist^.concat(new(pai68k,op_ref(
+                                    A_TST,S_B,newreference(p^.right^.location.reference))))
+                                else
+                                  exprasmlist^.concat(new(pai68k,op_ref(
+                                    A_TST,S_B,newreference(p^.left^.location.reference))));
+                             end
+                           else
+                             begin
+                               pushusedregisters(pushedregs,$ffff);
+                               emitpushreferenceaddr(p^.left^.location.reference);
+                               emitpushreferenceaddr(p^.right^.location.reference);
+                               emitcall('STRCMP',true);
+                               maybe_loada5;
+                               popusedregisters(pushedregs);
+                          end;
+                           ungetiftemp(p^.left^.location.reference);
+                           ungetiftemp(p^.right^.location.reference);
+                        end; { end this case }
+                else Message(sym_e_type_mismatch);
+              end; { end case }
+           end { end else if }
+         else
+           begin
+              { in case of constant put it to the left }
+              if p^.left^.treetype=ordconstn then
+                begin
+                   swapp:=p^.right;
+                   p^.right:=p^.left;
+                   p^.left:=swapp;
+                   p^.swaped:=not(p^.swaped);
+                end;
+              secondpass(p^.left);
+              set_location(p^.location,p^.left^.location);
+              { are to few registers free? }
+              pushed:=maybe_push(p^.right^.registers32,p);
+              secondpass(p^.right);
+              if pushed then restore(p);
+              if (p^.left^.resulttype^.deftype=pointerdef) or
+
+                 (p^.right^.resulttype^.deftype=pointerdef) or
+
+                 ((p^.right^.resulttype^.deftype=objectdef) and
+                  pobjectdef(p^.right^.resulttype)^.isclass and
+                 (p^.left^.resulttype^.deftype=objectdef) and
+                  pobjectdef(p^.left^.resulttype)^.isclass
+                 ) or
+
+                 (p^.left^.resulttype^.deftype=classrefdef) or
+
+                 (p^.left^.resulttype^.deftype=procvardef) or
+
+                 (p^.left^.resulttype^.deftype=enumdef) or
+
+                 ((p^.left^.resulttype^.deftype=orddef) and
+                 (porddef(p^.left^.resulttype)^.typ=s32bit)) or
+                 ((p^.right^.resulttype^.deftype=orddef) and
+                 (porddef(p^.right^.resulttype)^.typ=s32bit)) or
+
+                ((p^.left^.resulttype^.deftype=orddef) and
+                 (porddef(p^.left^.resulttype)^.typ=u32bit)) or
+                 ((p^.right^.resulttype^.deftype=orddef) and
+                 (porddef(p^.right^.resulttype)^.typ=u32bit)) or
+
+                { as well as small sets }
+                ((p^.left^.resulttype^.deftype=setdef) and
+                 (psetdef(p^.left^.resulttype)^.settype=smallset)
+                ) then
+                begin
+           do_normal:
+                   mboverflow:=false;
+                   cmpop:=false;
+                   if (p^.left^.resulttype^.deftype=pointerdef) or
+                      (p^.right^.resulttype^.deftype=pointerdef) or
+                      ((p^.left^.resulttype^.deftype=orddef) and
+                      (porddef(p^.left^.resulttype)^.typ=u32bit)) or
+                      ((p^.right^.resulttype^.deftype=orddef) and
+                      (porddef(p^.right^.resulttype)^.typ=u32bit)) then
+                     unsigned:=true;
+                   is_set:=p^.resulttype^.deftype=setdef;
+
+                   case p^.treetype of
+                      addn : begin
+                                if is_set then
+                                  begin
+                                     op:=A_OR;
+                                     mboverflow:=false;
+                                     unsigned:=false;
+                                  end
+                                else
+                                  begin
+                                     op:=A_ADD;
+                                     mboverflow:=true;
+                                  end;
+                             end; { end this case }
+                        symdifn : begin
+                                  { the symetric diff is only for sets }
+                                  if is_set then
+                                    begin
+                                       op:=A_EOR;
+                                       mboverflow:=false;
+                                       unsigned:=false;
+                                    end
+                                  else
+                                    begin
+                                       Message(sym_e_type_mismatch);
+                                    end;
+                               end;
+
+                      muln : begin
+                                if is_set then
+                                  begin
+                                     op:=A_AND;
+                                     mboverflow:=false;
+                                     unsigned:=false;
+                                  end
+                                else
+                                  begin
+                                     if unsigned then
+                                       op:=A_MULU
+                                     else
+                                       op:=A_MULS;
+                                     mboverflow:=true;
+                                  end;
+                             end; { end this case }
+                      subn : begin
+                                if is_set then
+                                  begin
+                                     op:=A_AND;
+                                     mboverflow:=false;
+                                     unsigned:=false;
+                                     extra_not:=true;
+                                  end
+                                else
+                                  begin
+                                     op:=A_SUB;
+                                     mboverflow:=true;
+                                  end;
+                             end; {end this case }
+                      ltn,lten,gtn,gten,
+                      equaln,unequaln :
+                             begin
+                                op:=A_CMP;
+                                cmpop:=true;
+                             end;
+                      xorn : op:=A_EOR;
+                      orn : op:=A_OR;
+                      andn : op:=A_AND;
+                      else Message(sym_e_type_mismatch);
+                   end; {end case }
+                   { left and right no register?  }
+                   { then one must be demanded    }
+                   if (p^.left^.location.loc<>LOC_REGISTER) and
+                     (p^.right^.location.loc<>LOC_REGISTER) then
+                     begin
+                        { register variable ? }
+                        if (p^.left^.location.loc=LOC_CREGISTER) then
+                          begin
+                               { it is OK if this is the destination }
+                               if is_in_dest then
+                                 begin
+                                    hregister:=p^.location.register;
+                                    emit_reg_reg(A_MOVE,opsize,p^.left^.location.register,
+                                      hregister);
+                                 end
+                               else
+                             if cmpop then
+                               begin
+                                  { do not disturb the register }
+                                  hregister:=p^.location.register;
+                               end
+                             else
+                               begin
+                                  hregister := getregister32;
+                                  emit_reg_reg(A_MOVE,opsize,p^.left^.location.register,
+                                    hregister);
+                               end
+                          end
+                        else
+                          begin
+                             del_reference(p^.left^.location.reference);
+                               if is_in_dest then
+                                 begin
+                                    hregister:=p^.location.register;
+                                    exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,
+                                    newreference(p^.left^.location.reference),hregister)));
+                                 end
+                               else
+                                 begin
+
+                                 { first give free, then demand new register }
+                                 hregister := getregister32;
+                                 exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,
+                                   newreference(p^.left^.location.reference),
+                                    hregister)));
+                                 end;{ endif p^... }
+                          end;
+
+                        p^.location.loc:=LOC_REGISTER;
+                        p^.location.register:=hregister;
+
+                     end
+                   else
+                     { if on the right the register then swap }
+                     if (p^.right^.location.loc=LOC_REGISTER) then
+                       begin
+                          swap_location(p^.location,p^.right^.location);
+
+                          { newly swapped also set swapped flag }
+                          p^.swaped:=not(p^.swaped);
+                       end;
+                   { endif p^...<> LOC_REGISTER }
+                   { at this point, p^.location.loc should be LOC_REGISTER }
+                   { and p^.location.register should be a valid register   }
+                   { containing the left result                    }
+                   if p^.right^.location.loc<>LOC_REGISTER then
+                     begin
+                        if (p^.treetype=subn) and p^.swaped then
+                          begin
+                             if p^.right^.location.loc=LOC_CREGISTER then
+                               begin
+                                  if extra_not then
+                                    exprasmlist^.concat(new(pai68k,op_reg(A_NOT,opsize,p^.location.register)));
+
+
+                                  emit_reg_reg(A_MOVE,opsize,p^.right^.location.register,R_D6);
+                                  emit_reg_reg(op,opsize,p^.location.register,R_D6);
+                                  emit_reg_reg(A_MOVE,opsize,R_D6,p^.location.register);
+                               end
+                             else
+                               begin
+                                  if extra_not then
+                                    exprasmlist^.concat(new(pai68k,op_reg(A_NOT,opsize,p^.location.register)));
+
+                                  exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,
+                                    newreference(p^.right^.location.reference),R_D6)));
+                                  exprasmlist^.concat(new(pai68k,op_reg_reg(op,opsize,p^.location.register,R_D6)));
+                                  exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,opsize,R_D6,p^.location.register)));
+                                  del_reference(p^.right^.location.reference);
+                               end;
+                          end
+                          { end subn ... }
+                        else
+                          begin
+                             if (p^.right^.treetype=ordconstn) and (op=A_CMP) and
+                                (p^.right^.value=0) then
+                               begin
+                                  exprasmlist^.concat(new(pai68k,op_reg(A_TST,opsize,p^.location.register)));
+                               end
+                             else if (p^.right^.treetype=ordconstn) and (op=A_MULS) and
+                                (ispowerof2(p^.right^.value,power)) then
+                               begin
+                                  if (power <= 8) then
+                                      exprasmlist^.concat(new(pai68k,op_const_reg(A_ASL,opsize,power,
+                                        p^.location.register)))
+                                  else
+                                   begin
+
+                                      exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,power,
+                                        R_D6)));
+                                      exprasmlist^.concat(new(pai68k,op_reg_reg(A_ASL,opsize,R_D6,
+                                        p^.location.register)))
+                                   end;
+                               end
+                             else
+                               begin
+                                  if (p^.right^.location.loc=LOC_CREGISTER) then
+                                    begin
+                                       if extra_not then
+                                         begin
+                                            emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,R_D6);
+                                            exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,R_D6)));
+                                            emit_reg_reg(A_AND,S_L,R_D6,
+                                              p^.location.register);
+                                         end
+                                       else
+                                         begin
+                                            if (op=A_MULS) and (opsize = S_L) and (opt_processors=MC68000) then
+                                            { Emulation for MC68000 }
+                                            begin
+                                              emit_reg_reg(A_MOVE,opsize,p^.right^.location.register,
+                                                 R_D0);
+                                              emit_reg_reg(A_MOVE,opsize,p^.location.register,R_D1);
+                                              emitcall('LONGMUL',true);
+                                              emit_reg_reg(A_MOVE,opsize,R_D0,p^.location.register);
+                                            end
+                                            else
+                                            if (op=A_MULU) and (opsize = S_L) and (opt_processors=MC68000) then
+                                             Message(cg_f_32bit_not_supported_in_68000)
+                                            else
+                                              emit_reg_reg(op,opsize,p^.right^.location.register,
+                                                p^.location.register);
+                                         end;
+                                    end
+                                  else
+                                    begin
+                                       if extra_not then
+                                         begin
+                                            exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(
+                                              p^.right^.location.reference),R_D6)));
+                                            exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,R_D6)));
+                                            emit_reg_reg(A_AND,S_L,R_D6,
+                                              p^.location.register);
+                                         end
+                                       else
+                                         begin
+                                            if (op=A_MULS) and (opsize = S_L) and (opt_processors=MC68000) then
+                                            { Emulation for MC68000 }
+                                            begin
+                                              exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE, opsize,
+                                                 newreference(p^.right^.location.reference),R_D1)));
+                                              emit_reg_reg(A_MOVE,opsize,p^.location.register,R_D0);
+                                              emitcall('LONGMUL',true);
+                                              emit_reg_reg(A_MOVE,opsize,R_D0,p^.location.register);
+                                            end
+                                            else
+                                            if (op=A_MULU) and (opsize = S_L) and (opt_processors=MC68000) then
+                                             Message(cg_f_32bit_not_supported_in_68000)
+                                            else
+                                              exprasmlist^.concat(new(pai68k,op_ref_reg(op,opsize,newreference(
+                                                p^.right^.location.reference),p^.location.register)));
+                                         end;
+                                       del_reference(p^.right^.location.reference);
+                                    end;
+                               end;
+                          end;
+                     end
+                   else
+                     begin
+                        { when swapped another result register }
+                        if (p^.treetype=subn) and p^.swaped then
+                          begin
+                             if extra_not then
+                               exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.location.register)));
+
+                             exprasmlist^.concat(new(pai68k,op_reg_reg(op,opsize,
+                               p^.location.register,p^.right^.location.register)));
+                               swap_location(p^.location,p^.right^.location);
+                               { newly swapped also set swapped flag }
+                               { just to maintain ordering           }
+                               p^.swaped:=not(p^.swaped);
+                          end
+                        else
+                          begin
+                             if extra_not then
+                                   exprasmlist^.concat(new(pai68k,op_reg(A_NOT,S_L,p^.right^.location.register)));
+
+                             if (op=A_MULS) and (opsize = S_L) and (opt_processors=MC68000) then
+                             { Emulation for MC68000 }
+                             begin
+                               emit_reg_reg(A_MOVE,opsize,p^.right^.location.register,
+                               R_D0);
+                               emit_reg_reg(A_MOVE,opsize,p^.location.register,R_D1);
+                               emitcall('LONGMUL',true);
+                               emit_reg_reg(A_MOVE,opsize,R_D0,p^.location.register);
+                             end
+                             else
+                             if (op=A_MULU) and (opsize = S_L) and (opt_processors=MC68000) then
+                              Message(cg_f_32bit_not_supported_in_68000)
+                             else
+
+                               exprasmlist^.concat(new(pai68k,op_reg_reg(op,opsize,
+                               p^.right^.location.register,
+                               p^.location.register)));
+                          end;
+                           ungetregister32(p^.right^.location.register);
+                     end;
+
+                   if cmpop then
+                        ungetregister32(p^.location.register);
+                   { only in case of overflow operations }
+                   { produce overflow code }
+                   if mboverflow then
+                     emitoverflowcheck;
+               end
+              else if ((p^.left^.resulttype^.deftype=orddef) and
+                 (porddef(p^.left^.resulttype)^.typ=uchar)) then
+                begin
+                   case p^.treetype of
+                      ltn,lten,gtn,gten,
+                      equaln,unequaln :
+                                cmpop:=true;
+                      else Message(sym_e_type_mismatch);
+                   end;
+                   unsigned:=true;
+                   { left and right no register? }
+                   { the one must be demanded    }
+                   if (p^.location.loc<>LOC_REGISTER) and
+                     (p^.right^.location.loc<>LOC_REGISTER) then
+                     begin
+                        if p^.location.loc=LOC_CREGISTER then
+                          begin
+                             if cmpop then
+                               { do not disturb register }
+                               hregister:=p^.location.register
+                             else
+                               begin
+                                  hregister:=getregister32;
+                                  emit_reg_reg(A_MOVE,S_B,p^.location.register,
+                                    hregister);
+                               end;
+                          end
+                        else
+                          begin
+                             del_reference(p^.location.reference);
+
+                             { first give free then demand new register }
+                             hregister:=getregister32;
+                             exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(p^.location.reference),
+                               hregister)));
+                          end;
+                        p^.location.loc:=LOC_REGISTER;
+                        p^.location.register:=hregister;
+                     end;
+
+                   { now p always a register }
+
+                   if (p^.right^.location.loc=LOC_REGISTER) and
+                      (p^.location.loc<>LOC_REGISTER) then
+                     begin
+                       swap_location(p^.location,p^.right^.location);
+
+                        { newly swapped also set swapped flag }
+                        p^.swaped:=not(p^.swaped);
+                     end;
+                   if p^.right^.location.loc<>LOC_REGISTER then
+                     begin
+                        if p^.right^.location.loc=LOC_CREGISTER then
+                          begin
+                             emit_reg_reg(A_CMP,S_B,
+                                p^.right^.location.register,p^.location.register);
+                          end
+                        else
+                          begin
+                             exprasmlist^.concat(new(pai68k,op_ref_reg(A_CMP,S_B,newreference(
+                                p^.right^.location.reference),p^.location.register)));
+                             del_reference(p^.right^.location.reference);
+                          end;
+                     end
+                   else
+                     begin
+                        emit_reg_reg(A_CMP,S_B,p^.right^.location.register,
+                          p^.location.register);
+                        ungetregister32(p^.right^.location.register);
+                     end;
+                   ungetregister32(p^.location.register);
+                end
+
+
+{*********************************************************************}
+
+              else if (p^.left^.resulttype^.deftype=floatdef) and
+                  (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then
+                 begin
+                    { real constants to the left }
+                    if p^.left^.treetype=realconstn then
+                      begin
+                         swapp:=p^.right;
+                         p^.right:=p^.left;
+                         p^.left:=swapp;
+                         p^.swaped:=not(p^.swaped);
+                      end;
+                    cmpop:=false;
+                    case p^.treetype of
+                       addn : op:=A_FADD;
+                       muln : op:=A_FMUL;
+                       subn : op:=A_FSUB;
+                       slashn : op:=A_FDIV;
+                       ltn,lten,gtn,gten,
+                       equaln,unequaln : begin
+                                            op:=A_FCMP;
+                                            cmpop:=true;
+                                         end;
+                       else Message(sym_e_type_mismatch);
+                    end;
+
+                    if (p^.left^.location.loc <> LOC_FPU) and
+                       (p^.right^.location.loc <> LOC_FPU) then
+                      begin
+                         { we suppose left in reference }
+                         del_reference(p^.left^.location.reference);
+                         { get a copy, since we don't want to modify the same }
+                         { node at the same time.                             }
+                         tmpref:=p^.left^.location.reference;
+                         if assigned(p^.left^.location.reference.symbol) then
+                           tmpref.symbol:=stringdup(p^.left^.location.reference.symbol^);
+
+                         floatload(pfloatdef(p^.left^.resulttype)^.typ, tmpref,
+                           p^.left^.location);
+                         clear_reference(tmpref);
+                      end
+                    else
+                      begin
+                        if (p^.right^.location.loc = LOC_FPU)
+                        and(p^.left^.location.loc <> LOC_FPU) then
+                           begin
+                             swap_location(p^.left^.location, p^.right^.location);
+                             p^.swaped := not(p^.swaped);
+                           end
+                      end;
+
+                   { ---------------- LEFT = LOC_FPUREG -------------------- }
+                       if ((p^.treetype =subn) or (p^.treetype = slashn)) and (p^.swaped) then
+                          {  fpu_reg =  right(FP1) / fpu_reg }
+                          {  fpu_reg = right(FP1) -  fpu_reg  }
+                          begin
+                             if (cs_fp_emulation in aktswitches) then
+                              begin
+                               { fpu_reg = right / D1 }
+                               { fpu_reg = right - D1 }
+                                  exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D0)));
+
+
+                                  { load value into D1 }
+                                  if p^.right^.location.loc <> LOC_FPU then
+                                     exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+                                       newreference(p^.right^.location.reference),R_D1)))
+                                  else
+                                     emit_reg_reg(A_MOVE,S_L,p^.right^.location.fpureg,R_D1);
+
+                                  { probably a faster way to do this but... }
+                                  case op of
+                                   A_FADD: emitcall('SINGLE_ADD',true);
+                                   A_FMUL: emitcall('SINGLE_MUL',true);
+                                   A_FSUB: emitcall('SINGLE_SUB',true);
+                                   A_FDIV: emitcall('SINGLE_DIV',true);
+                                   A_FCMP: emitcall('SINGLE_CMP',true);
+                                  end;
+                                  if not cmpop then { only flags are affected with cmpop }
+                                     exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,
+                                       p^.left^.location.fpureg)));
+
+                                  { if this was a reference, then delete as it }
+                                  { it no longer required.                     }
+                                  if p^.right^.location.loc <> LOC_FPU then
+                                     del_reference(p^.right^.location.reference);
+                              end
+                             else
+                              begin
+
+                                  if p^.right^.location.loc <> LOC_FPU then
+                                    exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,
+                                       getfloatsize(pfloatdef(p^.left^.resulttype)^.typ),
+                                      newreference(p^.right^.location.reference),
+                                      R_FP1)))
+                                  else
+                                    { FPm --> FPn must use extended precision }
+                                    emit_reg_reg(A_FMOVE,S_X,p^.right^.location.fpureg,R_FP1);
+
+                                  { arithmetic expression performed in extended mode }
+                                  exprasmlist^.concat(new(pai68k,op_reg_reg(op,S_X,
+                                      p^.left^.location.fpureg,R_FP1)));
+
+                                  { cmpop does not change any floating point register!! }
+                                  if not cmpop then
+                                       emit_reg_reg(A_FMOVE,S_X,R_FP1,p^.left^.location.fpureg)
+{                                       exprasmlist^.concat(new(pai68k,op_reg_reg(A_FMOVE,
+                                       getfloatsize(pfloatdef(p^.left^.resulttype)^.typ),
+                                       R_FP1,p^.left^.location.fpureg)))}
+                                  else
+                                  { process comparison, to make it compatible with the rest of the code }
+                                      processcc(p);
+
+                                  { if this was a reference, then delete as it }
+                                  { it no longer required.                     }
+                                  if p^.right^.location.loc <> LOC_FPU then
+                                     del_reference(p^.right^.location.reference);
+                              end;
+                          end
+                       else { everything is in the right order }
+                         begin
+                           {  fpu_reg = fpu_reg / right }
+                           {  fpu_reg = fpu_reg - right }
+                           { + commutative ops }
+                           if cs_fp_emulation in aktswitches then
+                           begin
+
+                             { load value into D7 }
+                             if p^.right^.location.loc <> LOC_FPU then
+                               exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,
+                                 newreference(p^.right^.location.reference),R_D0)))
+                             else
+                               emit_reg_reg(A_MOVE,S_L,p^.right^.location.fpureg,R_D0);
+
+                             emit_reg_reg(A_MOVE,S_L,p^.left^.location.fpureg,R_D1);
+                             { probably a faster way to do this but... }
+                             case op of
+                               A_FADD: emitcall('SINGLE_ADD',true);
+                               A_FMUL: emitcall('SINGLE_MUL',true);
+                               A_FSUB: emitcall('SINGLE_SUB',true);
+                               A_FDIV: emitcall('SINGLE_DIV',true);
+                               A_FCMP: emitcall('SINGLE_CMP',true);
+                             end;
+                             if not cmpop then { only flags are affected with cmpop }
+                               exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D0,
+                                 p^.left^.location.fpureg)));
+                             { if this was a reference, then delete as it }
+                             { it no longer required.                     }
+                             if p^.right^.location.loc <> LOC_FPU then
+                               del_reference(p^.right^.location.reference);
+                           end
+                           else
+                           begin
+                             if p^.right^.location.loc <> LOC_FPU then
+                               exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,
+                                 getfloatsize(pfloatdef(p^.left^.resulttype)^.typ),
+                                 newreference(p^.right^.location.reference),R_FP1)))
+                             else
+                               emit_reg_reg(A_FMOVE,getfloatsize(pfloatdef(p^.left^.resulttype)^.typ),
+                                 p^.right^.location.fpureg,R_FP1);
+
+                               emit_reg_reg(op,S_X,R_FP1,p^.left^.location.fpureg);
+
+                               if cmpop then
+                                 processcc(p);
+
+                             { if this was a reference, then delete as it }
+                             { it no longer required.                     }
+                             if p^.right^.location.loc <> LOC_FPU then
+                               del_reference(p^.right^.location.reference);
+
+                           end
+                         end; { endif treetype = .. }
+
+
+                         if cmpop then
+                          begin
+                             if p^.swaped then
+                                 case p^.treetype of
+                                     equaln: flags := F_E;
+                                     unequaln: flags := F_NE;
+                                     ltn : flags := F_G;
+                                     lten : flags := F_GE;
+                                     gtn : flags := F_L;
+                                     gten: flags := F_LE;
+                                 end
+                             else
+                                 case p^.treetype of
+                                     equaln: flags := F_E;
+                                     unequaln : flags := F_NE;
+                                     ltn: flags := F_L;
+                                     lten : flags := F_LE;
+                                     gtn : flags := F_G;
+                                     gten: flags := F_GE;
+                                 end;
+                             p^.location.loc := LOC_FLAGS;
+                             p^.location.resflags := flags;
+                             cmpop := false;
+                          end
+                         else
+                         begin
+                             p^.location.loc := LOC_FPU;
+                             if p^.left^.location.loc = LOC_FPU then
+                             { copy fpu register result . }
+                             { HERE ON EXIT FPU REGISTER IS IN EXTENDED MODE! }
+                                p^.location.fpureg := p^.left^.location.fpureg
+                             else
+                             begin
+                               InternalError(34);
+                             end;
+                         end;
+
+                end
+{*********************************************************************}
+              else if (p^.left^.resulttype^.deftype=setdef) then
+                begin
+                   { not commutative }
+                   if p^.swaped then
+                     begin
+                        swapp:=p^.left;
+                        p^.left:=p^.right;
+                        p^.right:=swapp;
+                        { because of jump being produced by comparison }
+                        p^.swaped:=not(p^.swaped);
+                     end;
+                   case p^.treetype of
+                      equaln,unequaln : begin
+                                     cmpop:=true;
+                                     del_reference(p^.left^.location.reference);
+                                     del_reference(p^.right^.location.reference);
+                                     pushusedregisters(pushedregs,$ffff);
+                                     emitpushreferenceaddr(p^.right^.location.reference);
+                                     emitpushreferenceaddr(p^.left^.location.reference);
+                                     emitcall('SET_COMP_SETS',true);
+                                     maybe_loada5;
+                                     popusedregisters(pushedregs);
+                                     ungetiftemp(p^.left^.location.reference);
+                                     ungetiftemp(p^.right^.location.reference);
+                                  end;
+
+                      addn,subn,muln,symdifn : begin
+                                     cmpop:=false;
+                                     del_reference(p^.left^.location.reference);
+                                     del_reference(p^.right^.location.reference);
+                                     href.symbol:=nil;
+                                     pushusedregisters(pushedregs,$ffff);
+                                     gettempofsizereference(32,href);
+                                     emitpushreferenceaddr(href);
+                                     { wrong place !! was hard to find out
+                                     pushusedregisters(pushedregs,$ff);}
+                                     emitpushreferenceaddr(p^.right^.location.reference);
+                                     emitpushreferenceaddr(p^.left^.location.reference);
+                                     case p^.treetype of
+                                       subn : exprasmlist^.concat(new(pai68k,op_csymbol(A_JSR,S_NO,
+                                         newcsymbol('SET_SUB_SETS',0))));
+                                       addn : exprasmlist^.concat(new(pai68k,op_csymbol(A_JSR,S_NO,
+                                         newcsymbol('SET_ADD_SETS',0))));
+                                       muln : exprasmlist^.concat(new(pai68k,op_csymbol(A_JSR,S_NO,
+                                         newcsymbol('SET_MUL_SETS',0))));
+                                     end;
+                                     maybe_loada5;
+                                     popusedregisters(pushedregs);
+                                     ungetiftemp(p^.left^.location.reference);
+                                     ungetiftemp(p^.right^.location.reference);
+                                     p^.location.loc:=LOC_MEM;
+                                     stringdispose(p^.location.reference.symbol);
+                                     p^.location.reference:=href;
+                                  end;
+                      else Message(sym_e_type_mismatch);
+                   end; { end case }
+                end {else if begin }
+              else Message(sym_e_type_mismatch);
+           end; { endif }
+          if (p^.left^.resulttype^.deftype<>stringdef) and
+             not ((p^.left^.resulttype^.deftype=setdef) and
+                (psetdef(p^.left^.resulttype)^.settype<>smallset)) then
+            begin
+               { this can be useful if for instance length(string) is called }
+               if (p^.left^.location.loc=LOC_REFERENCE) or
+                  (p^.left^.location.loc=LOC_MEM) then
+                 ungetiftemp(p^.left^.location.reference);
+               if (p^.right^.location.loc=LOC_REFERENCE) or
+                  (p^.right^.location.loc=LOC_MEM) then
+                 ungetiftemp(p^.right^.location.reference);
+            end;
+
+         { in case of comparison operation the put result in the flags }
+         if cmpop then
+           begin
+              if not(unsigned) then
+                begin
+                   if p^.swaped then
+                     case p^.treetype of
+                        equaln : flags:=F_E;
+                        unequaln : flags:=F_NE;
+                        ltn : flags:=F_G;
+                        lten : flags:=F_GE;
+                        gtn : flags:=F_L;
+                        gten : flags:=F_LE;
+                     end
+                   else
+                     case p^.treetype of
+                        equaln : flags:=F_E;
+                        unequaln : flags:=F_NE;
+                        ltn : flags:=F_L;
+                        lten : flags:=F_LE;
+                        gtn : flags:=F_G;
+                        gten : flags:=F_GE;
+                     end;
+                end
+              else
+                begin
+                   if p^.swaped then
+                     case p^.treetype of
+                        equaln : flags:=F_E;
+                        unequaln : flags:=F_NE;
+                        ltn : flags:=F_A;
+                        lten : flags:=F_AE;
+                        gtn : flags:=F_B;
+                        gten : flags:=F_BE;
+                     end
+                   else
+                     case p^.treetype of
+                        equaln : flags:=F_E;
+                        unequaln : flags:=F_NE;
+                        ltn : flags:=F_B;
+                        lten : flags:=F_BE;
+                        gtn : flags:=F_A;
+                        gten : flags:=F_AE;
+                     end;
+                end; { end begin }
+              p^.location.loc:=LOC_FLAGS;
+              p^.location.resflags:=flags;
+           end; { endif cmpop }
+      end;
+
+ procedure processcc(p: ptree);
+ var
+   label1,label2: plabel;
+ (*************************************************************************)
+ (*  Description: This routine handles the conversion of Floating point   *)
+ (*  condition codes to normal cpu condition codes.                       *)
+ (*************************************************************************)
+ begin
+      getlabel(label1);
+      getlabel(label2);
+      case p^.treetype of
+        equaln,unequaln: begin
+                           { not equal clear zero flag }
+                           emitl(A_FBEQ,label1);
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_AND, S_B, NOT ZERO_FLAG, R_CCR)));
+                           emitl(A_BRA,label2);
+                           emitl(A_LABEL,label1);
+                           { equal - set zero flag }
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_OR,S_B, ZERO_FLAG, R_CCR)));
+                           emitl(A_LABEL,label2);
+                        end;
+         ltn:           begin
+                           emitl(A_FBLT,label1);
+                           { not less than       }
+                           { clear N and V flags }
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_AND, S_B, NOT (NEG_FLAG OR OVFL_FLAG), R_CCR)));
+                           emitl(A_BRA,label2);
+                           emitl(A_LABEL,label1);
+                           { less than }
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_OR,S_B, NEG_FLAG, R_CCR)));
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_AND,S_B, NOT OVFL_FLAG, R_CCR)));
+                           emitl(A_LABEL,label2);
+                        end;
+         gtn:           begin
+                           emitl(A_FBGT,label1);
+                           { not greater than }
+                           { set Z flag       }
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_OR, S_B, ZERO_FLAG, R_CCR)));
+                           emitl(A_BRA,label2);
+                           emitl(A_LABEL,label1);
+                           { greater than      }
+                           { set N and V flags }
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_OR,S_B, NEG_FLAG OR OVFL_FLAG , R_CCR)));
+                           emitl(A_LABEL,label2);
+                        end;
+         gten:           begin
+                           emitl(A_FBGE,label1);
+                           { not greater or equal }
+                           { set N and clear V    }
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_AND, S_B, NOT OVFL_FLAG, R_CCR)));
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_OR,S_B, NEG_FLAG, R_CCR)));
+                           emitl(A_BRA,label2);
+                           emitl(A_LABEL,label1);
+                           { greater or equal    }
+                           { clear V and N flags }
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_AND, S_B, NOT (OVFL_FLAG OR NEG_FLAG), R_CCR)));
+                           emitl(A_LABEL,label2);
+                        end;
+         lten:           begin
+                           emitl(A_FBLE,label1);
+                           { not less or equal }
+                           { clear Z, N and V  }
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_AND, S_B, NOT (ZERO_FLAG OR NEG_FLAG OR OVFL_FLAG), R_CCR)));
+                           emitl(A_BRA,label2);
+                           emitl(A_LABEL,label1);
+                           { less or equal     }
+                           { set Z and N       }
+                           { and clear V       }
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_OR,S_B, ZERO_FLAG OR NEG_FLAG, R_CCR)));
+                           exprasmlist^.concat(new(pai68k, op_const_reg(
+                             A_AND,S_B, NOT OVFL_FLAG, R_CCR)));
+                           emitl(A_LABEL,label2);
+                        end;
+           else
+             begin
+               InternalError(34);
+             end;
+      end; { end case }
+ end;
+
+    procedure secondfor(var p : ptree);
+
+      var
+         l1,l3,oldclabel,oldblabel : plabel;
+         omitfirstcomp,temptovalue : boolean;
+         hs : byte;
+         temp1 : treference;
+         hop : tasmop;
+         cmpreg,cmp32 : tregister;
+         opsize : topsize;
+         count_var_is_signed : boolean;
+
+      begin
+         oldclabel:=aktcontinuelabel;
+         oldblabel:=aktbreaklabel;
+         getlabel(aktcontinuelabel);
+         getlabel(aktbreaklabel);
+         getlabel(l3);
+
+         { could we spare the first comparison ? }
+         omitfirstcomp:=false;
+         if p^.right^.treetype=ordconstn then
+           if p^.left^.right^.treetype=ordconstn then
+             omitfirstcomp:=(p^.backward and (p^.left^.right^.value>=p^.right^.value))
+               or (not(p^.backward) and (p^.left^.right^.value<=p^.right^.value));
+
+         { only calculate reference }
+         cleartempgen;
+         secondpass(p^.t2);
+         if not(simple_loadn) then
+          Message(cg_e_illegal_count_var);
+
+         { produce start assignment }
+         cleartempgen;
+         secondpass(p^.left);
+         count_var_is_signed:=is_signed(porddef(p^.t2^.resulttype));
+         hs:=p^.t2^.resulttype^.size;
+         cmp32:=getregister32;
+         cmpreg:=cmp32;
+         case hs of
+            1 : begin
+                   opsize:=S_B;
+                end;
+            2 : begin
+                   opsize:=S_W;
+                end;
+            4 : begin
+                   opsize:=S_L;
+                end;
+         end;
+         cleartempgen;
+         secondpass(p^.right);
+         { calculate pointer value and check if changeable and if so }
+         { load into temporary variable                              }
+         if p^.right^.treetype<>ordconstn then
+           begin
+              temp1.symbol:=nil;
+              gettempofsizereference(hs,temp1);
+              temptovalue:=true;
+              if (p^.right^.location.loc=LOC_REGISTER) or
+                 (p^.right^.location.loc=LOC_CREGISTER) then
+                begin
+                   exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,opsize,p^.right^.location.register,
+                      newreference(temp1))));
+                 end
+              else
+                 concatcopy(p^.right^.location.reference,temp1,hs,false);
+           end
+         else temptovalue:=false;
+
+         if temptovalue then
+           begin
+              if p^.t2^.location.loc=LOC_CREGISTER then
+               begin
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_CMP,opsize,newreference(temp1),
+                     p^.t2^.location.register)));
+                end
+              else
+                begin
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,newreference(p^.t2^.location.reference),
+                     cmpreg)));
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_CMP,opsize,newreference(temp1),
+                     cmpreg)));
+                end;
+           end
+         else
+           begin
+              if not(omitfirstcomp) then
+                begin
+                   if p^.t2^.location.loc=LOC_CREGISTER then
+                     exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^.right^.value,
+                       p^.t2^.location.register)))
+                   else
+                     exprasmlist^.concat(new(pai68k,op_const_ref(A_CMP,opsize,p^.right^.value,
+               newreference(p^.t2^.location.reference))));
+                end;
+           end;
+         if p^.backward then
+          begin
+           if count_var_is_signed then
+              hop:=A_BLT
+           else
+              hop:=A_BCS;
+          end
+         else
+           if count_var_is_signed then
+             hop:=A_BGT
+           else hop:=A_BHI;
+
+         if not(omitfirstcomp) or temptovalue then
+          emitl(hop,aktbreaklabel);
+
+         emitl(A_LABEL,l3);
+
+         { help register must not be in instruction block }
+         cleartempgen;
+         if assigned(p^.t1) then
+           secondpass(p^.t1);
+
+         emitl(A_LABEL,aktcontinuelabel);
+
+         { makes no problems there }
+         cleartempgen;
+
+         { demand help register again }
+         cmp32:=getregister32;
+         case hs of
+            1 : begin
+                   opsize:=S_B;
+                end;
+            2 : begin
+                   opsize:=S_W;
+                end;
+            4 : opsize:=S_L;
+         end;
+
+     { produce comparison and the corresponding }
+     { jump                                     }
+         if temptovalue then
+           begin
+              if p^.t2^.location.loc=LOC_CREGISTER then
+                begin
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_CMP,opsize,newreference(temp1),
+                     p^.t2^.location.register)));
+                end
+              else
+                begin
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,opsize,newreference(p^.t2^.location.reference),
+                     cmpreg)));
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_CMP,opsize,newreference(temp1),
+                     cmpreg)));
+                end;
+           end
+         else
+           begin
+              if p^.t2^.location.loc=LOC_CREGISTER then
+                exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,opsize,p^.right^.value,
+                  p^.t2^.location.register)))
+              else
+                exprasmlist^.concat(new(pai68k,op_const_ref(A_CMP,opsize,p^.right^.value,
+                  newreference(p^.t2^.location.reference))));
+           end;
+         if p^.backward then
+           if count_var_is_signed then
+             hop:=A_BLE
+           else
+             hop :=A_BLS
+          else
+            if count_var_is_signed then
+              hop:=A_BGE
+            else
+               hop:=A_BCC;
+         emitl(hop,aktbreaklabel);
+         { according to count direction DEC or INC... }
+         { must be after the test because of 0to 255 for bytes !! }
+         if p^.backward then
+           hop:=A_SUB
+         else hop:=A_ADD;
+
+         if p^.t2^.location.loc=LOC_CREGISTER then
+           exprasmlist^.concat(new(pai68k,op_const_reg(hop,opsize,1,p^.t2^.location.register)))
+         else
+            exprasmlist^.concat(new(pai68k,op_const_ref(hop,opsize,1,newreference(p^.t2^.location.reference))));
+         emitl(A_JMP,l3);
+
+     { this is the break label: }
+         emitl(A_LABEL,aktbreaklabel);
+         ungetregister32(cmp32);
+
+         if temptovalue then
+           ungetiftemp(temp1);
+
+         aktcontinuelabel:=oldclabel;
+         aktbreaklabel:=oldblabel;
+      end;
+
+
+    procedure secondas(var p : ptree);
+
+      var
+         pushed : tpushed;
+
+      begin
+         secondpass(p^.left);
+         { save all used registers }
+         pushusedregisters(pushed,$ffff);
+
+         { push instance to check: }
+         case p^.left^.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,
+                S_L,p^.left^.location.register,R_SPPUSH)));
+            LOC_MEM,LOC_REFERENCE:
+              exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,
+                S_L,newreference(p^.left^.location.reference),R_SPPUSH)));
+            else internalerror(100);
+         end;
+
+         { we doesn't modifiy the left side, we check only the type }
+         set_location(p^.location,p^.left^.location);
+
+         { generate type checking }
+         secondpass(p^.right);
+         case p^.right^.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              begin
+                 exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,
+                   S_L,p^.right^.location.register,R_SPPUSH)));
+                 ungetregister32(p^.right^.location.register);
+              end;
+            LOC_MEM,LOC_REFERENCE:
+              begin
+                 exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,
+                   S_L,newreference(p^.right^.location.reference),R_SPPUSH)));
+                 del_reference(p^.right^.location.reference);
+              end;
+            else internalerror(100);
+         end;
+         emitcall('DO_AS',true);
+         { restore register, this restores automatically the }
+         { result                                            }
+         popusedregisters(pushed);
+      end;
+
+
+    { generates the code for a raise statement }
+    procedure secondraise(var p : ptree);
+
+      var
+         a : plabel;
+
+      begin
+         if assigned(p^.left) then
+           begin
+              { generate the address }
+              if assigned(p^.right) then
+                begin
+                   secondpass(p^.right);
+                   if codegenerror then
+                     exit;
+                end
+              else
+                begin
+                   getlabel(a);
+                   emitl(A_LABEL,a);
+                   exprasmlist^.concat(new(pai68k,
+                     op_csymbol_reg(A_MOVE,S_L,newcsymbol(lab2str(a),0),R_SPPUSH)));
+                end;
+              secondpass(p^.left);
+              if codegenerror then
+                exit;
+
+              case p^.left^.location.loc of
+                 LOC_MEM,LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference);
+                 LOC_CREGISTER,LOC_REGISTER : exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
+                   p^.left^.location.register,R_SPPUSH)));
+                 else Message(sym_e_type_mismatch);
+              end;
+              emitcall('DO_RAISE',true);
+           end
+         else
+           emitcall('DO_RERAISE',true);
+      end;
+
+
+
+
+    { copies p a set element on the stack }
+    procedure pushsetelement(var p : ptree);
+
+      var
+         hr : tregister;
+
+      begin
+         { copy the element on the stack, slightly complicated }
+         case p^.location.loc of
+            LOC_REGISTER,
+            LOC_CREGISTER : begin
+                              hr:=p^.location.register;
+                              exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,hr,R_SPPUSH)));
+                              ungetregister32(hr);
+                           end;
+            else
+               begin
+                  exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,
+                    newreference(p^.location.reference),R_SPPUSH)));
+                  del_reference(p^.location.reference);
+               end;
+         end;
+      end;
+
+    { could be built into secondadd but it }
+    { should be easy to read }
+    procedure secondin(var p : ptree);
+
+
+      type  Tsetpart=record
+                range:boolean;      {Part is a range.}
+                start,stop:byte;    {Start/stop when range; Stop=element
+                                     when an element.}
+            end;
+
+      var
+         pushed,ranges : boolean;
+         hr : tregister;
+         setparts:array[1..8] of Tsetpart;
+         i,numparts:byte;
+         href,href2:Treference;
+         l,l2 : plabel;
+       hl,hl1 : plabel;
+
+
+            function analizeset(Aset:Pconstset):boolean;
+
+            var compares,maxcompares:word;
+                i:byte;
+            type    byteset=set of byte;
+
+            begin
+                analizeset:=false;
+                ranges:=false;
+                numparts:=0;
+                compares:=0;
+                {Lots of comparisions take a lot of time, so do not allow
+                 too much comparisions. 8 comparisions are, however, still
+                 smalller than emitting the set.}
+                maxcompares:=5;
+                if cs_littlesize in aktswitches then
+                    maxcompares:=8;
+                for i:=0 to 255 do
+                    if i in byteset(Aset^) then
+                        begin
+                            if (numparts=0) or
+                             (i<>setparts[numparts].stop+1) then
+                                begin
+                                    {Set element is a separate element.}
+                                    inc(compares);
+                                    if compares>maxcompares then
+                                        exit;
+                                    inc(numparts);
+                                    setparts[numparts].range:=false;
+                                    setparts[numparts].stop:=i;
+                                end
+                             else
+                                {Set element is part of a range.}
+                                if not setparts[numparts].range then
+                                    begin
+                                        {Transform an element into a range.}
+                                        setparts[numparts].range:=true;
+                                        setparts[numparts].start:=
+                                         setparts[numparts].stop;
+                                        setparts[numparts].stop:=i;
+                                        inc(compares);
+                                        if compares>maxcompares then
+                                            exit;
+                                    end
+                                else
+                                    begin
+                                        {Extend a range.}
+                                        setparts[numparts].stop:=i;
+                                        {A range of two elements can better
+                                         be checked as two separate ones.
+                                         When extending a range, our range
+                                         becomes larger than two elements.}
+                                        ranges:=true;
+                                    end;
+                        end;
+                analizeset:=true;
+            end;
+
+      begin
+         if psetdef(p^.right^.resulttype)^.settype=smallset then
+           begin
+              if p^.left^.treetype=ordconstn then
+                begin
+                   { only compulsory }
+                   secondpass(p^.left);
+                       secondpass(p^.right);
+                   if codegenerror then
+                     exit;
+                   p^.location.resflags:=F_NE;
+                       case p^.right^.location.loc of
+                      LOC_REGISTER,LOC_CREGISTER : begin
+                                                    emit_reg_reg(A_MOVE,S_L,p^.right^.location.register,R_D1);
+                                                    exprasmlist^.concat(new(pai68k,
+                                                      op_const_reg(A_AND,S_L, 1 shl
+                                                       (p^.left^.value and 31),R_D1)));
+                                                   end;
+                      else
+                       begin
+                           exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(
+                             p^.right^.location.reference),R_D1)));
+                           exprasmlist^.concat(new(pai68k,op_const_reg(
+                             A_AND,S_L, 1 shl (p^.left^.value and 31),R_D1)));
+                       end;
+                   end;
+                   del_reference(p^.right^.location.reference);
+                end
+              else
+                begin
+                   { calculate both operators }
+                   { the complex one first }
+                   firstcomplex(p);
+                   secondpass(p^.left);
+                   { are too few registers free? }
+                   pushed:=maybe_push(p^.right^.registers32,p^.left);
+                   secondpass(p^.right);
+                   if pushed then
+                     restore(p^.left);
+                   { of course not commutative }
+                   if p^.swaped then
+                        swaptree(p);
+              { load index into register }
+                   case p^.left^.location.loc of
+                      LOC_REGISTER,
+                      LOC_CREGISTER :
+                                        hr:=p^.left^.location.register;
+                      else
+                         begin
+                            { the set element isn't never samller than a byte  }
+                            { and because it's a small set we need only 5 bits }
+                            { but 8 bits are eaiser to load                    }
+                            exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,
+                              newreference(p^.left^.location.reference),R_D1)));
+                            hr:=R_D1;
+                            del_reference(p^.left^.location.reference);
+                         end;
+                   end;
+                   case p^.right^.location.loc of
+                      LOC_REGISTER,
+                      LOC_CREGISTER : exprasmlist^.concat(new(pai68k, op_reg_reg(A_BTST,S_L,hr,p^.right^.location.register)));
+                      else
+                         begin
+                     { OOPS ... bug here thanks Florian!! }
+                     exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(p^.right^.location.reference),
+                        R_D0)));
+                            exprasmlist^.concat(new(pai68k,op_reg_reg(A_BTST,S_L,hr,R_D0)));
+                            del_reference(p^.right^.location.reference);
+                         end;
+                   end;
+                   { support carry routines }
+                   { sets the carry flags according to the result of BTST }
+                   { i.e the Z flag.                                      }
+                   getlabel(hl);
+                   emitl(A_BNE,hl);
+                   { leave all bits unchanged except Carry  = 0 }
+                   exprasmlist^.concat(new(pai68k, op_const_reg(A_AND, S_B, $FE, R_CCR)));
+                   getlabel(hl1);
+                   emitl(A_BRA,hl1);
+                   emitl(A_LABEL, hl);
+                   { set carry to 1 }
+                   exprasmlist^.concat(new(pai68k, op_const_reg(A_OR, S_B, $01, R_CCR)));
+                   emitl(A_LABEL, hl1);
+                   { end support carry routines }
+                   p^.location.loc:=LOC_FLAGS;
+                   p^.location.resflags:=F_C;
+                end;
+           end
+         else
+           begin
+              if p^.left^.treetype=ordconstn then
+                begin
+                   { only compulsory }
+                   secondpass(p^.left);
+                   secondpass(p^.right);
+                   if codegenerror then
+                     exit;
+                   p^.location.resflags:=F_NE;
+                   inc(p^.right^.location.reference.offset,p^.left^.value shr 3);
+                   exprasmlist^.concat(new(pai68k, op_ref_reg(A_MOVE, S_B,
+                       newreference(p^.right^.location.reference), R_D1)));
+                   exprasmlist^.concat(new(pai68k, op_const_reg(A_AND, S_B,
+                       1 shl (p^.left^.value and 7),R_D1)));
+               del_reference(p^.right^.location.reference);
+            end
+          else
+            begin
+               if (p^.right^.treetype=setconstrn) and
+                  analizeset(p^.right^.constset) then
+                    begin
+                        {It gives us advantage to check for the set elements
+                         separately instead of using the SET_IN_BYTE procedure.
+                         To do: Build in support for LOC_JUMP.}
+                        secondpass(p^.left);
+                        {We won't do a second pass on p^.right, because
+                         this will emit the constant set.}
+                      case p^.left^.location.loc of
+                        LOC_REGISTER,
+                        LOC_CREGISTER :
+                           exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_L,
+                             255,p^.left^.location.register)));
+                      end;
+                            {Get a label to jump to the end.}
+                            p^.location.loc:=LOC_FLAGS;
+                            {It's better to use the zero flag when there are
+                             no ranges.}
+                            if ranges then
+                                p^.location.resflags:=F_C
+                            else
+                                p^.location.resflags:=F_E;
+                            href.symbol := nil;
+                            clear_reference(href);
+                            getlabel(l);
+                            href.symbol:=stringdup(lab2str(l));
+                            for i:=1 to numparts do
+                                if setparts[i].range then
+                                    begin
+                                        {Check if left is in a range.}
+                                        {Get a label to jump over the check.}
+                                        href2.symbol := nil;
+                                        clear_reference(href2);
+                                        getlabel(l2);
+                                        href.symbol:=stringdup(lab2str(l2));
+                                        if setparts[i].start=setparts[i].stop-1 then
+                                            begin
+                                       case p^.left^.location.loc of
+                                           LOC_REGISTER,
+                                           LOC_CREGISTER :
+                                                  exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,S_B,
+                                                    setparts[i].start,p^.left^.location.register)));
+                                    else
+                                                  exprasmlist^.concat(new(pai68k,op_const_ref(A_CMP,S_B,
+                                                    setparts[i].start,newreference(p^.left^.location.reference))));
+                                    end;
+                                                {Result should be in carry flag when ranges are used.}
+                                                if ranges then
+                                                    exprasmlist^.concat(new(pai68k,op_const_reg(A_OR,S_B,$01,R_CCR)));
+
+                                                {If found, jump to end.}
+                                                emitl(A_BEQ,l);
+                                       case p^.left^.location.loc of
+                                           LOC_REGISTER,
+                                           LOC_CREGISTER :
+                                                exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,S_B,
+                                                 setparts[i].stop,p^.left^.location.register)));
+                                    else
+                                                exprasmlist^.concat(new(pai68k,op_const_ref(A_CMP,S_B,
+                                                 setparts[i].stop,newreference(p^.left^.location.reference))));
+                                    end;
+                                                {If found, jump to end.}
+                                                emitl(A_BEQ,l);
+                                            end
+                                        else
+                                            begin
+                                                if setparts[i].start<>0 then
+                                                    begin
+                                                        {We only check for the lower bound if it is > 0, because
+                                                         set elements lower than 0 do nt exist.}
+                                           case p^.left^.location.loc of
+                                               LOC_REGISTER,
+                                               LOC_CREGISTER :
+                                                        exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,S_B,
+                                                         setparts[i].start,p^.left^.location.register)));
+                                          else
+                                                        exprasmlist^.concat(new(pai68k,op_const_ref(A_CMP,S_B,
+                                                         setparts[i].start,newreference(p^.left^.location.reference))));
+                                          end;
+                                                        {If lower, jump to next check.}
+                                                        emitl(A_BCS,l2);
+                                                    end;
+                                                if setparts[i].stop<>255 then
+                                                    begin
+                                                        {We only check for the high bound if it is < 255, because
+                                                         set elements higher than 255 do nt exist.}
+                                           case p^.left^.location.loc of
+                                               LOC_REGISTER,
+                                               LOC_CREGISTER :
+                                                            exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,S_B,
+                                                         setparts[i].stop+1,p^.left^.location.register)));
+                                          else
+                                                        exprasmlist^.concat(new(pai68k,op_const_ref(A_CMP,S_B,
+                                                         setparts[i].stop+1,newreference(p^.left^.location.reference))));
+                                          end; { end case }
+                                                        {If higher, element is in set.}
+                                                        emitl(A_BCS,l);
+                                                    end;
+                                            end;
+                                        {Emit the jump over label.}
+                                        exprasmlist^.concat(new(pai_label,init(l2)));
+                                    end
+                                else
+                                    begin
+                                        {Emit code to check if left is an element.}
+                              case p^.left^.location.loc of
+                                LOC_REGISTER,
+                                LOC_CREGISTER :
+                                        exprasmlist^.concat(new(pai68k,op_const_reg(A_CMP,S_B,
+                                         setparts[i].stop,p^.left^.location.register)));
+                              else
+                                        exprasmlist^.concat(new(pai68k,op_const_ref(A_CMP,S_B,
+                                         setparts[i].stop,newreference(p^.left^.location.reference))));
+                              end;
+                                        {Result should be in carry flag when ranges are used.}
+                                        if ranges then
+                                            exprasmlist^.concat(new(pai68k, op_const_reg(A_OR,S_B,$01,R_CCR)));
+                                        {If found, jump to end.}
+                                        emitl(A_BEQ,l);
+                                    end;
+                            if ranges then
+                            { clear carry flag }
+                                exprasmlist^.concat(new(pai68k,op_const_reg(A_AND,S_B,$FE,R_CCR)));
+                            {To compensate for not doing a second pass.}
+                            stringdispose(p^.right^.location.reference.symbol);
+                            {Now place the end label.}
+                            exprasmlist^.concat(new(pai_label,init(l)));
+                        end
+                   else
+                        begin
+                           { calculate both operators }
+                           { the complex one first }
+                           firstcomplex(p);
+                           secondpass(p^.left);
+                           set_location(p^.location,p^.left^.location);
+                           { are too few registers free? }
+                           pushed:=maybe_push(p^.right^.registers32,p);
+                           secondpass(p^.right);
+                           if pushed then restore(p);
+                           { of course not commutative }
+                           if p^.swaped then
+                             swaptree(p);
+                           pushsetelement(p^.left);
+                           emitpushreferenceaddr(p^.right^.location.reference);
+                           del_reference(p^.right^.location.reference);
+                           { registers need not be save. that happens in SET_IN_BYTE }
+                           emitcall('SET_IN_BYTE',true);
+                     { ungetiftemp(p^.right^.location.reference); }
+                           p^.location.loc:=LOC_FLAGS;
+                           p^.location.resflags:=F_C;
+                        end;
+                end;
+             end;
+      end;
+
+
+
+    procedure secondexpr(var p : ptree);
+
+      begin
+         secondpass(p^.left);
+      end;
+
+    procedure secondblockn(var p : ptree);
+
+      var
+         hp : ptree;
+
+      begin
+         hp:=p^.left;
+         while assigned(hp) do
+           begin
+              { assignments could be distance optimized }
+              if assigned(hp^.right) then
+                begin
+                   cleartempgen;
+                   secondpass(hp^.right);
+                end;
+              hp:=hp^.left;
+           end;
+      end;
+
+    procedure second_while_repeatn(var p : ptree);
+
+      var
+         l1,l2,l3,oldclabel,oldblabel : plabel;
+         otlabel,oflabel : plabel;
+      begin
+         getlabel(l1);
+         getlabel(l2);
+         { arrange continue and breaklabels: }
+         oldclabel:=aktcontinuelabel;
+         oldblabel:=aktbreaklabel;
+         if p^.treetype=repeatn then
+           begin
+              emitl(A_LABEL,l1);
+              aktcontinuelabel:=l1;
+              aktbreaklabel:=l2;
+              cleartempgen;
+              if assigned(p^.right) then
+               secondpass(p^.right);
+
+              otlabel:=truelabel;
+              oflabel:=falselabel;
+              truelabel:=l2;
+              falselabel:=l1;
+              cleartempgen;
+              secondpass(p^.left);
+              maketojumpbool(p^.left);
+              emitl(A_LABEL,l2);
+              truelabel:=otlabel;
+              falselabel:=oflabel;
+           end
+         else
+           begin
+              { handling code at the end as it is much more efficient }
+              emitl(A_JMP,l2);
+
+              emitl(A_LABEL,l1);
+              cleartempgen;
+
+              getlabel(l3);
+              aktcontinuelabel:=l1;
+              aktbreaklabel:=l3;
+
+              if assigned(p^.right) then
+               secondpass(p^.right);
+
+              emitl(A_LABEL,l2);
+              otlabel:=truelabel;
+              oflabel:=falselabel;
+              truelabel:=l1;
+              falselabel:=l3;
+              cleartempgen;
+              secondpass(p^.left);
+              maketojumpbool(p^.left);
+
+              emitl(A_LABEL,l3);
+              truelabel:=otlabel;
+              falselabel:=oflabel;
+           end;
+         aktcontinuelabel:=oldclabel;
+         aktbreaklabel:=oldblabel;
+      end;
+
+    procedure secondifn(var p : ptree);
+
+      var
+         hl,otlabel,oflabel : plabel;
+
+      begin
+         otlabel:=truelabel;
+         oflabel:=falselabel;
+         getlabel(truelabel);
+         getlabel(falselabel);
+         cleartempgen;
+         secondpass(p^.left);
+         maketojumpbool(p^.left);
+         if assigned(p^.right) then
+           begin
+              emitl(A_LABEL,truelabel);
+              cleartempgen;
+              secondpass(p^.right);
+           end;
+         if assigned(p^.t1) then
+           begin
+              if assigned(p^.right) then
+                begin
+                   getlabel(hl);
+                   emitl(A_JMP,hl);
+                end;
+              emitl(A_LABEL,falselabel);
+              cleartempgen;
+              secondpass(p^.t1);
+              if assigned(p^.right) then
+                emitl(A_LABEL,hl);
+           end
+         else
+           emitl(A_LABEL,falselabel);
+         if not(assigned(p^.right)) then
+           emitl(A_LABEL,truelabel);
+         truelabel:=otlabel;
+         falselabel:=oflabel;
+      end;
+
+    procedure secondbreakn(var p : ptree);
+
+      begin
+         if aktbreaklabel<>nil then
+           emitl(A_JMP,aktbreaklabel)
+         else
+           Message(cg_e_break_not_allowed);
+      end;
+
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:13  root
+  Initial revision
+
+  Revision 1.18  1998/03/10 01:17:15  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.17  1998/03/09 10:44:34  peter
+    + string='', string<>'', string:='', string:=char optimizes (the first 2
+      were already in cg68k2)
+
+  Revision 1.16  1998/03/06 00:52:02  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.15  1998/03/02 01:48:15  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.14  1998/02/14 05:05:43  carl
+    + now compiles under TP with overlays
+
+  Revision 1.13  1998/02/13 10:34:44  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.12  1998/02/12 11:49:49  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.11  1998/02/07 06:51:51  carl
+    + moved secondraise from cg68k
+
+  Revision 1.10  1998/02/05 21:54:31  florian
+    + more MMX
+
+  Revision 1.9  1998/02/05 00:59:29  carl
+    + added secondas
+
+  Revision 1.8  1998/02/01 17:13:26  florian
+    + comparsion of class references
+
+  Revision 1.7  1998/01/21 22:34:23  florian
+    + comparsion of Delphi classes
+
+  Revision 1.6  1998/01/11 03:37:18  carl
+  * bugfix of muls.l under MC68000 target
+  * long subtract bugfix
+
+  Revision 1.3  1997/12/10 23:07:15  florian
+  * bugs fixed: 12,38 (also m68k),39,40,41
+  + warning if a system unit is without -Us compiled
+  + warning if a method is virtual and private (was an error)
+  * some indentions changed
+  + factor does a better error recovering (omit some crashes)
+  + problem with @type(x) removed (crashed the compiler)
+
+  Revision 1.2  1997/12/04 15:15:05  carl
+  + updated to v099.
+
+  Revision 1.1.1.1  1997/11/27 08:32:53  michael
+  FPC Compiler CVS start
+
+
+  Pre-CVS log:
+
+
+  FK     Florian Klaempfl
+  +      feature added
+  -      removed
+  *      bug fixed or changed
+
+  History:
+       8th october 1997:
+         + only a cmpb $0,_S is generated if s is a string and a
+           s='' or s<>'' is performed (FK)
+      17th october 1997:
+         + unit started (CEC)
+
+}

compiler/cga68k.pas

@@ -0,0 +1,1340 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl, Carl Eric Codere
+
+    This unit generates 68000 (or better) assembler from the parse tree
+
+    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 cga68k;
+
+  interface
+
+    uses
+       objects,cobjects,verbose,systems,globals,tree,symtable,types,strings,
+       pass_1,hcodegen,aasm,m68k,tgen68k,files,gdb;
+
+    procedure emitl(op : tasmop;var l : plabel);
+    procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister);
+    procedure emitcall(const routine:string;add_to_externals : boolean);
+    procedure emitloadord2reg(location:Tlocation;orddef:Porddef;
+                              destreg:Tregister;delloc:boolean);
+    { produces jumps to true respectively false labels using boolean expressions }
+    procedure maketojumpbool(p : ptree);
+    procedure emitoverflowcheck;
+    procedure push_int(l : longint);
+    function maybe_push(needed : byte;p : ptree) : boolean;
+    procedure restore(p : ptree);
+    procedure emit_push_mem(const ref : treference);
+    procedure emitpushreferenceaddr(const ref : treference);
+    procedure swaptree(p: ptree);
+    procedure copystring(const dref,sref : treference;len : byte);
+    procedure concatcopy(source,dest : treference;size : longint;delsource : boolean);
+    { see implementation }
+    procedure maybe_loada5;
+    procedure emit_bounds_check(hp: treference; index: tregister);
+    procedure loadstring(p:ptree);
+
+    procedure floatload(t : tfloattype;const ref : treference; var location:tlocation);
+    { return a float op_size from a floatb type  }
+    { also does some error checking for problems }
+    function getfloatsize(t: tfloattype): topsize;
+    procedure floatstore(t : tfloattype;var location:tlocation; const ref:treference);
+{    procedure floatloadops(t : tfloattype;var op : tasmop;var s : topsize);
+    procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize); }
+
+    procedure firstcomplex(p : ptree);
+    procedure secondfuncret(var p : ptree);
+
+    { initialize respectively terminates the code generator }
+    { for a new module or procedure                         }
+    procedure codegen_doneprocedure;
+    procedure codegen_donemodule;
+    procedure codegen_newmodule;
+    procedure codegen_newprocedure;
+
+    { generate entry code for a procedure.}
+    procedure genentrycode(const proc_names:Tstringcontainer;make_global:boolean;
+                           stackframe:longint;
+                           var parasize:longint;var nostackframe:boolean);
+    { generate the exit code for a procedure. }
+    procedure genexitcode(parasize:longint;nostackframe:boolean);
+
+
+  implementation
+
+    {
+    procedure genconstadd(size : topsize;l : longint;const str : string);
+
+      begin
+         if l=0 then
+         else if l=1 then
+           exprasmlist^.concat(new(pai68k,op_A_INC,size,str)
+         else if l=-1 then
+           exprasmlist^.concat(new(pai68k,op_A_INC,size,str)
+         else
+           exprasmlist^.concat(new(pai68k,op_ADD,size,'$'+tostr(l)+','+str);
+      end;
+    }
+    procedure copystring(const dref,sref : treference;len : byte);
+
+      var
+         pushed : tpushed;
+
+      begin
+         pushusedregisters(pushed,$ffff);
+         emitpushreferenceaddr(dref);
+         emitpushreferenceaddr(sref);
+         push_int(len);
+         emitcall('STRCOPY',true);
+         maybe_loada5;
+         popusedregisters(pushed);
+      end;
+
+
+    procedure loadstring(p:ptree);
+      begin
+        case p^.right^.resulttype^.deftype of
+         stringdef : begin
+                       { load a string ... }
+                       { here two possible choices:      }
+                       { if it is a char, then simply    }
+                       { load 0 length string            }
+                       if (p^.right^.treetype=stringconstn) and
+                          (p^.right^.values^='') then
+                        exprasmlist^.concat(new(pai68k,op_const_ref(
+                           A_MOVE,S_B,0,newreference(p^.left^.location.reference))))
+                       else
+                        copystring(p^.left^.location.reference,p^.right^.location.reference,
+                           min(pstringdef(p^.right^.resulttype)^.len,pstringdef(p^.left^.resulttype)^.len));
+                     end;
+            orddef : begin
+                       if p^.right^.treetype=ordconstn then
+                        begin
+                            exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_W,p^.right^.value*256+1,
+                              newreference(p^.left^.location.reference))))
+                        end
+                       else
+                         begin
+                            { not so elegant (goes better with extra register }
+                            if (p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+                              begin
+                                 exprasmlist^.concat(new(pai68k,op_reg_reg(
+                                    A_MOVE,S_L,p^.right^.location.register,R_D0)));
+                                 ungetregister32(p^.right^.location.register);
+                              end
+                            else
+                              begin
+                                 exprasmlist^.concat(new(pai68k,op_ref_reg(
+                                    A_MOVE,S_L,newreference(p^.right^.location.reference),R_D0)));
+                                 del_reference(p^.right^.location.reference);
+                              end;
+                            if (opt_processors = MC68020) then
+                             { alignment is not a problem on the 68020 and higher processors }
+                              Begin
+                               { add length of string to word }
+                                exprasmlist^.concat(new(pai68k,op_const_reg(A_OR,S_W,$0100,R_D0)));
+                               { put back into mem ...        }
+                                exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_W,R_D0,
+                                  newreference(p^.left^.location.reference))));
+                             end
+                           else
+                             Begin
+                              { alignment can cause problems }
+                              { add length of string to ref }
+                               exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,1,
+                                  newreference(p^.left^.location.reference))));
+                               if abs(p^.left^.location.reference.offset) >= 1 then
+                                 Begin
+                                 { temporarily decrease offset }
+                                   Inc(p^.left^.location.reference.offset);
+                                   exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_B,R_D0,
+                                     newreference(p^.left^.location.reference))));
+                                   Dec(p^.left^.location.reference.offset);
+                                 { restore offset }
+                                 end
+                               else
+                                Begin
+                                 Comment(V_Debug,'SecondChar2String() internal error.');
+                                 internalerror(34);
+                                end;
+                             end;
+                         end;
+                       end;
+        else
+         Message(sym_e_type_mismatch);
+        end;
+      end;
+
+
+
+
+
+    procedure restore(p : ptree);
+
+      var
+         hregister :  tregister;
+
+      begin
+         hregister:=getregister32;
+         exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_SPPULL,hregister)));
+         if (p^.location.loc=LOC_REGISTER) or (p^.location.loc=LOC_CREGISTER) then
+           begin
+              p^.location.register:=hregister;
+           end
+         else
+           begin
+              reset_reference(p^.location.reference);
+              p^.location.reference.index:=hregister;
+              set_location(p^.left^.location,p^.location);
+           end;
+      end;
+
+    function maybe_push(needed : byte;p : ptree) : boolean;
+
+      var
+         pushed : boolean;
+         {hregister : tregister; }
+         reg: tregister;
+      begin
+         if needed>usablereg32 then
+           begin
+              if (p^.location.loc=LOC_REGISTER) or
+                 (p^.location.loc=LOC_CREGISTER) then
+                begin
+                   pushed:=true;
+                   exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.location.register,R_SPPUSH)));
+                   ungetregister32(p^.location.register);
+                end
+              else if ((p^.location.loc=LOC_MEM) or
+                       (p^.location.loc=LOC_REFERENCE)
+                      ) and
+                      ((p^.location.reference.base<>R_NO) or
+                       (p^.location.reference.index<>R_NO)
+                      ) then
+                  begin
+                     del_reference(p^.location.reference);
+                     exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.location.reference),
+               R_A0)));
+             exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A0,R_SPPUSH)));
+                     pushed:=true;
+                  end
+              else pushed:=false;
+           end
+         else pushed:=false;
+         maybe_push:=pushed;
+      end;
+
+
+    { emit out of range check for arrays and sets}
+    procedure emit_bounds_check(hp: treference; index: tregister);
+    { index = index of array to check }
+    { memory of range check information for array }
+     var
+      hl : plabel;
+     begin
+        if (opt_processors = MC68020) then
+          begin
+             exprasmlist^.concat(new(pai68k, op_ref_reg(A_CMP2,S_L,newreference(hp),index)));
+             getlabel(hl);
+             emitl(A_BCC, hl);
+             exprasmlist^.concat(new(pai68k, op_const_reg(A_MOVE,S_L,201,R_D0)));
+             emitcall('HALT_ERROR',true);
+             emitl(A_LABEL, hl);
+          end
+        else
+          begin
+            exprasmlist^.concat(new(pai68k, op_ref_reg(A_LEA,S_L,newreference(hp), R_A1)));
+            exprasmlist^.concat(new(pai68k, op_reg_reg(A_MOVE, S_L, index, R_D0)));
+            emitcall('RE_BOUNDS_CHECK',true);
+          end;
+     end;
+
+
+
+    function getfloatsize(t: tfloattype): topsize;
+    begin
+      case t of
+      s32real: getfloatsize := S_S;
+      s64real: getfloatsize := S_Q;
+      s80real: getfloatsize := S_X;
+{$ifdef extdebug}
+    else {else case }
+      begin
+        Comment(V_Debug,' getfloatsize() trying to get unknown size.');
+        internalerror(12);
+      end;
+{$endif}
+     end;
+    end;
+
+    procedure emitl(op : tasmop;var l : plabel);
+
+      begin
+         if op=A_LABEL then
+           exprasmlist^.concat(new(pai_label,init(l)))
+         else
+           exprasmlist^.concat(new(pai_labeled,init(op,l)))
+      end;
+
+    procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister);
+
+      begin
+         if (reg1 <> reg2) or (i <> A_MOVE) then
+           exprasmlist^.concat(new(pai68k,op_reg_reg(i,s,reg1,reg2)));
+      end;
+
+
+    procedure emitcall(const routine:string;add_to_externals : boolean);
+
+     begin
+        exprasmlist^.concat(new(pai68k,op_csymbol(A_JSR,S_NO,newcsymbol(routine,0))));
+        if assem_need_external_list and add_to_externals and
+           not (cs_compilesystem in aktswitches) then
+          concat_external(routine,EXT_NEAR);
+     end;
+
+
+    procedure maketojumpbool(p : ptree);
+
+      begin
+         if p^.error then
+           exit;
+         if (p^.resulttype^.deftype=orddef) and
+            (porddef(p^.resulttype)^.typ=bool8bit) then
+           begin
+              if is_constboolnode(p) then
+                begin
+                   if p^.value<>0 then
+                     emitl(A_JMP,truelabel)
+                   else emitl(A_JMP,falselabel);
+                end
+              else
+                begin
+                   case p^.location.loc of
+                      LOC_CREGISTER,LOC_REGISTER : begin
+                                        exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_B,p^.location.register)));
+                                        ungetregister32(p^.location.register);
+                                        emitl(A_BNE,truelabel);
+                                        emitl(A_JMP,falselabel);
+                                     end;
+                      LOC_MEM,LOC_REFERENCE : begin
+                                        exprasmlist^.concat(new(pai68k,op_ref(
+                                          A_TST,S_B,newreference(p^.location.reference))));
+                                        del_reference(p^.location.reference);
+                                        emitl(A_BNE,truelabel);
+                                        emitl(A_JMP,falselabel);
+                                     end;
+                      LOC_FLAGS : begin
+                                     emitl(flag_2_jmp[p^.location.resflags],truelabel);
+                                     emitl(A_JMP,falselabel);
+                                  end;
+                   end;
+                end;
+           end
+         else
+          Message(sym_e_type_mismatch);
+      end;
+
+    procedure emitoverflowcheck;
+
+      var
+         hl : plabel;
+
+      begin
+         if cs_check_overflow in aktswitches  then
+           begin
+              getlabel(hl);
+              emitl(A_BVC,hl);
+              emitcall('RE_OVERFLOW',true);
+              emitl(A_LABEL,hl);
+           end;
+      end;
+
+    procedure push_int(l : longint);
+
+      begin
+         if (l = 0) and (opt_processors = MC68020) then
+           begin
+          exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,R_D6)));
+              exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
+          R_D6, R_SPPUSH)));
+           end
+         else
+         if not(cs_littlesize in aktswitches) and (l >= -128) and (l <= 127) then
+           begin
+           exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVEQ,S_L,l,R_D6)));
+           exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D6,R_SPPUSH)));
+           end
+         else
+           exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,l,R_SPPUSH)));
+      end;
+
+    procedure emit_push_mem(const ref : treference);
+
+      begin
+         if ref.isintvalue then
+           push_int(ref.offset)
+         else
+           exprasmlist^.concat(new(pai68k,op_ref(A_PEA,S_L,newreference(ref))));
+      end;
+
+
+    { USES REGISTER R_A1 }
+    procedure emitpushreferenceaddr(const ref : treference);
+
+      begin
+         if ref.isintvalue then
+           push_int(ref.offset)
+         else
+           begin
+              if (ref.base=R_NO) and (ref.index=R_NO) then
+                exprasmlist^.concat(new(pai68k,op_ref(A_PEA,S_L,
+                    newreference(ref))))
+              else if (ref.base=R_NO) and (ref.index<>R_NO) and
+                 (ref.offset=0) and (ref.scalefactor=0) and (ref.symbol=nil) then
+                exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
+                    ref.index,R_SPPUSH)))
+              else if (ref.base<>R_NO) and (ref.index=R_NO) and
+                 (ref.offset=0) and (ref.symbol=nil) then
+                exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,ref.base,R_SPPUSH)))
+              else
+                begin
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(ref),R_A1)));
+                   exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A1,R_SPPUSH)));
+                end;
+           end;
+        end;
+
+    procedure swaptree(p:Ptree);
+
+    var swapp:Ptree;
+
+    begin
+        swapp:=p^.right;
+        p^.right:=p^.left;
+        p^.left:=swapp;
+        p^.swaped:=not(p^.swaped);
+    end;
+
+
+procedure genentrycode(const proc_names:Tstringcontainer;make_global:boolean;
+                       stackframe:longint;
+                       var parasize:longint;var nostackframe:boolean);
+
+{Generates the entry code for a procedure.}
+
+var hs:string;
+    hp:Pused_unit;
+    unitinits:taasmoutput;
+{$ifdef GDB}
+    oldaktprocname : string;
+    stab_function_name:Pai_stab_function_name;
+{$endif GDB}
+begin
+    if (aktprocsym^.definition^.options and poproginit<>0) then
+        begin
+            {Init the stack checking.}
+            if (cs_check_stack in aktswitches) and
+             (target_info.target=target_linux) then
+                begin
+                    procinfo.aktentrycode^.insert(new(pai68k,
+                     op_csymbol(A_JSR,S_NO,newcsymbol('INIT_STACK_CHECK',0))));
+                end;
+
+            unitinits.init;
+
+            {Call the unit init procedures.}
+            hp:=pused_unit(usedunits.first);
+            while assigned(hp) do
+                begin
+                    { call the unit init code and make it external }
+                    if (hp^.u^.flags and uf_init)<>0 then
+                        begin
+                           unitinits.concat(new(pai68k,op_csymbol(A_JSR,S_NO,newcsymbol('INIT$$'+hp^.u^.unitname^,0))));
+                           externals^.concat(new(pai_external,init('INIT$$'+hp^.u^.unitname^,EXT_NEAR)));
+                        end;
+                   hp:=pused_unit(hp^.next);
+                end;
+              procinfo.aktentrycode^.insertlist(@unitinits);
+              unitinits.done;
+        end;
+
+        { a constructor needs a help procedure }
+        if (aktprocsym^.definition^.options and poconstructor)<>0 then
+        begin
+           if procinfo._class^.isclass then
+             begin
+              procinfo.aktentrycode^.insert(new(pai_labeled,init(A_BEQ,quickexitlabel)));
+              procinfo.aktentrycode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO,
+              newcsymbol('NEW_CLASS',0))));
+              concat_external('NEW_CLASS',EXT_NEAR);
+             end
+           else
+             begin
+              procinfo.aktentrycode^.insert(new(pai_labeled,init(A_BEQ,quickexitlabel)));
+              procinfo.aktentrycode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO,
+              newcsymbol('HELP_CONSTRUCTOR',0))));
+              concat_external('HELP_CONSTRUCTOR',EXT_NEAR);
+             end;
+        end;
+    { don't load ESI, does the caller }
+
+    { omit stack frame ? }
+    if procinfo.framepointer=stack_pointer then
+        begin
+            Message(cg_d_stackframe_omited);
+            nostackframe:=true;
+            if (aktprocsym^.definition^.options and (pounitinit or poproginit)<>0) then
+                parasize:=0
+            else
+                parasize:=aktprocsym^.definition^.parast^.datasize+procinfo.call_offset;
+        end
+    else
+        begin
+             if (aktprocsym^.definition^.options and (pounitinit or poproginit)<>0) then
+                parasize:=0
+             else
+                parasize:=aktprocsym^.definition^.parast^.datasize+procinfo.call_offset-8;
+            nostackframe:=false;
+            if stackframe<>0 then
+                begin
+                    if cs_littlesize in aktswitches  then
+                        begin
+                            if (cs_check_stack in aktswitches) and
+                             (target_info.target<>target_linux) then
+                                begin
+                                    procinfo.aktentrycode^.insert(new(pai68k,
+                                     op_csymbol(A_JSR,S_NO,newcsymbol('STACKCHECK',0))));
+                                    procinfo.aktentrycode^.insert(new(pai68k,op_const_reg(A_MOVE,S_L,stackframe,R_SPPUSH)));
+                                end;
+                            { to allocate stack space }
+                            { here we allocate space using link signed 16-bit version }
+                            { -ve offset to allocate stack space! }
+                            if (stackframe > -32767) and (stackframe < 32769) then
+                              procinfo.aktentrycode^.insert(new(pai68k,op_reg_const(A_LINK,S_W,R_A6,-stackframe)))
+                            else
+                              Message(cg_e_stacklimit_in_local_routine);
+                        end
+                    else
+                        begin
+                          { Not to complicate the code generator too much, and since some  }
+                          { of the systems only support this format, the stackframe cannot }
+                          { exceed 32K in size.                                            }
+                          if (stackframe > -32767) and (stackframe < 32769) then
+                            begin
+                              procinfo.aktentrycode^.insert(new(pai68k,op_const_reg(A_SUB,S_L,stackframe,R_SP)));
+                              if (cs_check_stack in aktswitches) then
+                                begin
+                                  procinfo.aktentrycode^.insert(new(pai68k,
+                                   op_csymbol(A_JSR,S_NO,newcsymbol('STACKCHECK',0))));
+                                  procinfo.aktentrycode^.insert(new(pai68k,op_const_reg(A_MOVE,S_L,
+                                    stackframe,R_SPPUSH)));
+                                  concat_external('STACKCHECK',EXT_NEAR);
+                                end;
+                               procinfo.aktentrycode^.insert(new(pai68k,op_reg_reg(A_MOVE,S_L,R_SP,R_A6)));
+                               procinfo.aktentrycode^.insert(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A6,R_SPPUSH)));
+                            end
+                          else
+                            Message(cg_e_stacklimit_in_local_routine);
+                        end;
+                end {endif stackframe<>0 }
+            else
+               begin
+                 procinfo.aktentrycode^.insert(new(pai68k,op_reg_reg(A_MOVE,S_L,R_SP,R_A6)));
+                 procinfo.aktentrycode^.insert(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A6,R_SPPUSH)));
+               end;
+        end;
+
+    if (aktprocsym^.definition^.options and pointerrupt)<>0 then
+        generate_interrupt_stackframe_entry;
+
+    {proc_names.insert(aktprocsym^.definition^.mangledname);}
+
+    if (aktprocsym^.definition^.owner^.symtabletype=globalsymtable) or
+     ((procinfo._class<>nil) and (procinfo._class^.owner^.
+     symtabletype=globalsymtable)) then
+        make_global:=true;
+    hs:=proc_names.get;
+
+{$IfDef GDB}
+    if (cs_debuginfo in aktswitches) and
+     target_info.use_function_relative_addresses then
+        stab_function_name := new(pai_stab_function_name,init(strpnew(hs)));
+      oldaktprocname:=aktprocsym^.name;
+{$EndIf GDB}
+
+
+    while hs<>'' do
+        begin
+              if make_global then
+                procinfo.aktentrycode^.insert(new(pai_symbol,init_global(hs)))
+              else
+                procinfo.aktentrycode^.insert(new(pai_symbol,init(hs)));
+{$ifdef GDB}
+            if (cs_debuginfo in aktswitches) and
+             target_info.use_function_relative_addresses then
+            begin
+            procinfo.aktentrycode^.insert(new(pai_stab_function_name,init(strpnew(hs))));
+              { This is not a nice solution to save the name, change it and restore when done }
+                 aktprocsym^.setname(hs);
+                 procinfo.aktentrycode^.insert(new(pai_stabs,init(aktprocsym^.stabstring)));
+        end;
+{$endif GDB}
+              hs:=proc_names.get;
+        end;
+{$ifdef GDB}
+      aktprocsym^.setname(oldaktprocname);
+
+    if (cs_debuginfo in aktswitches) then
+        begin
+            if target_info.use_function_relative_addresses then
+                procinfo.aktentrycode^.insert(stab_function_name);
+            if make_global or ((procinfo.flags and pi_is_global) <> 0) then
+                aktprocsym^.is_global := True;
+            {This is dead code! Because lexlevel is increased at the
+             start of compile_proc_body it can never be zero.}
+{           if (lexlevel > 0) and (oldprocsym^.definition^.localst^.name = nil) then
+                if oldprocsym^.owner^.symtabletype = objectsymtable then
+                    oldprocsym^.definition^.localst^.name := stringdup(oldprocsym^.owner^.name^+'_'+oldprocsym^.name)
+                else
+                    oldprocsym^.definition^.localst^.name := stringdup(oldprocsym^.name);}
+            aktprocsym^.isstabwritten:=true;
+        end;
+{$endif GDB}
+    { Alignment required for Motorola }
+    procinfo.aktentrycode^.insert(new(pai_align,init(2)));
+{$ifdef extdebug}
+    procinfo.aktentrycode^.insert(new(pai_direct,init(strpnew(target_info.newline))));
+{$endif extdebug}
+end;
+
+{Generate the exit code for a procedure.}
+procedure genexitcode(parasize:longint;nostackframe:boolean);
+
+var hr:Preference;          {This is for function results.}
+    op:Tasmop;
+    s:Topsize;
+
+begin
+    { !!!! insert there automatic destructors }
+
+    procinfo.aktexitcode^.insert(new(pai_label,init(aktexitlabel)));
+
+    { call the destructor help procedure }
+    if (aktprocsym^.definition^.options and podestructor)<>0 then
+     begin
+       if procinfo._class^.isclass then
+         begin
+           procinfo.aktexitcode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO,
+             newcsymbol('DISPOSE_CLASS',0))));
+           concat_external('DISPOSE_CLASS',EXT_NEAR);
+         end
+       else
+         begin
+           procinfo.aktexitcode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO,
+             newcsymbol('HELP_DESTRUCTOR',0))));
+           concat_external('HELP_DESTRUCTOR',EXT_NEAR);
+         end;
+     end;
+
+    { call __EXIT for main program }
+    { ????????? }
+    if (aktprocsym^.definition^.options and poproginit)<>0 then
+     begin
+       procinfo.aktexitcode^.concat(new(pai68k,op_csymbol(A_JSR,S_NO,newcsymbol('__EXIT',0))));
+       externals^.concat(new(pai_external,init('__EXIT',EXT_NEAR)));
+     end;
+
+    { handle return value }
+    if (aktprocsym^.definition^.options and poassembler)=0 then
+        if (aktprocsym^.definition^.options and poconstructor)=0 then
+            begin
+                if procinfo.retdef<>pdef(voiddef) then
+                    begin
+                        if not procinfo.funcret_is_valid then
+                          Message(sym_w_function_result_not_set);
+                        new(hr);
+                        reset_reference(hr^);
+                        hr^.offset:=procinfo.retoffset;
+                        hr^.base:=procinfo.framepointer;
+                        if (procinfo.retdef^.deftype=orddef) then
+                            begin
+                                case porddef(procinfo.retdef)^.typ of
+                                    s32bit,u32bit :
+                                        procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hr,R_D0)));
+                                    u8bit,s8bit,uchar,bool8bit :
+                                        procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,hr,R_D0)));
+                                    s16bit,u16bit :
+                                        procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,hr,R_D0)));
+                                end;
+                            end
+                        else
+                            if (procinfo.retdef^.deftype in [pointerdef,enumdef,procvardef]) or
+                             ((procinfo.retdef^.deftype=setdef) and
+                             (psetdef(procinfo.retdef)^.settype=smallset)) then
+                                procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hr,R_D0)))
+                            else
+                                if (procinfo.retdef^.deftype=floatdef) then
+                                    begin
+                                        if pfloatdef(procinfo.retdef)^.typ=f32bit then
+                                            begin
+                                                { Isnt this missing ? }
+                                                procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hr,R_D0)));
+                                            end
+                                        else
+                                            begin
+                                             { how the return value is handled                          }
+                                             { if in FPU mode, return in FP0                            }
+                                             if (pfloatdef(procinfo.retdef)^.typ = s32real)
+                                              and (cs_fp_emulation in aktswitches) then
+                                              begin
+                                                procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,
+                                                  S_L,hr,R_D0)))
+                                              end
+                                             else
+                                              begin
+                                               if cs_fp_emulation in aktswitches then
+                                                 procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,
+                                                    S_L,hr,R_D0)))
+                                               else
+                                                 procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_FMOVE,
+                                                 getfloatsize(pfloatdef(procinfo.retdef)^.typ),hr,R_FP0)));
+                                             end;
+                                           end;
+                                    end
+                                else
+                                    dispose(hr);
+                    end
+            end
+        else
+            begin
+                { successful constructor deletes the zero flag }
+                { and returns self in accumulator              }
+                procinfo.aktexitcode^.concat(new(pai_label,init(quickexitlabel)));
+                { eax must be set to zero if the allocation failed !!! }
+                procinfo.aktexitcode^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_D0)));
+                { faster then OR on mc68000/mc68020 }
+                procinfo.aktexitcode^.concat(new(pai68k,op_reg(A_TST,S_L,R_D0)));
+            end;
+    procinfo.aktexitcode^.concat(new(pai_label,init(aktexit2label)));
+    if not(nostackframe) then
+        procinfo.aktexitcode^.concat(new(pai68k,op_reg(A_UNLK,S_NO,R_A6)));
+
+    { at last, the return is generated }
+
+    if (aktprocsym^.definition^.options and pointerrupt)<>0 then
+        generate_interrupt_stackframe_exit
+    else
+        if (parasize=0) or ((aktprocsym^.definition^.options and poclearstack)<>0)
+        then
+            {Routines with the poclearstack flag set use only a ret.}
+            { also routines with parasize=0           }
+            procinfo.aktexitcode^.concat(new(pai68k,op_none(A_RTS,S_NO)))
+        else
+            { return with immediate size possible here }
+            { signed!                                  }
+            if (opt_processors = MC68020) and (parasize < $7FFF) then
+                procinfo.aktexitcode^.concat(new(pai68k,op_const(
+                 A_RTD,S_NO,parasize)))
+            { manually restore the stack }
+            else
+              begin
+                    { We must pull the PC Counter from the stack, before  }
+                    { restoring the stack pointer, otherwise the PC would }
+                    { point to nowhere!                                   }
+
+                    { save the PC counter (pop it from the stack)         }
+                    procinfo.aktexitcode^.concat(new(pai68k,op_reg_reg(
+                         A_MOVE,S_L,R_SPPULL,R_A0)));
+                    { can we do a quick addition ... }
+                    if (parasize > 0) and (parasize < 9) then
+                       procinfo.aktexitcode^.concat(new(pai68k,op_const_reg(
+                         A_ADD,S_L,parasize,R_SP)))
+                    else { nope ... }
+                       procinfo.aktexitcode^.concat(new(pai68k,op_const_reg(
+                         A_ADD,S_L,parasize,R_SP)));
+                    { endif }
+                    { restore the PC counter (push it on the stack)       }
+                    procinfo.aktexitcode^.concat(new(pai68k,op_reg_reg(
+                         A_MOVE,S_L,R_A0,R_SPPUSH)));
+                    procinfo.aktexitcode^.concat(new(pai68k,op_none(
+                      A_RTS,S_NO)))
+               end;
+{$ifdef GDB}
+    if cs_debuginfo in aktswitches  then
+        begin
+            aktprocsym^.concatstabto(procinfo.aktexitcode);
+            if assigned(procinfo._class) then
+                procinfo.aktexitcode^.concat(new(pai_stabs,init(strpnew(
+                 '"$t:v'+procinfo._class^.numberstring+'",'+
+                 tostr(N_PSYM)+',0,0,'+tostr(procinfo.esi_offset)))));
+
+            if (porddef(aktprocsym^.definition^.retdef) <> voiddef) then
+                procinfo.aktexitcode^.concat(new(pai_stabs,init(strpnew(
+                 '"'+aktprocsym^.name+':X'+aktprocsym^.definition^.retdef^.numberstring+'",'+
+                 tostr(N_PSYM)+',0,0,'+tostr(procinfo.retoffset)))));
+
+            procinfo.aktexitcode^.concat(new(pai_stabn,init(strpnew('192,0,0,'
+             +aktprocsym^.definition^.mangledname))));
+
+            procinfo.aktexitcode^.concat(new(pai_stabn,init(strpnew('224,0,0,'
+             +lab2str(aktexit2label)))));
+        end;
+{$endif * GDB *}
+end;
+
+
+    { USES REGISTERS R_A0 AND R_A1 }
+    procedure concatcopy(source,dest : treference;size : longint;delsource : boolean);
+
+      var
+         ecxpushed : boolean;
+         helpsize : longint;
+         i : byte;
+         reg8,reg32 : tregister;
+         swap : boolean;
+         hregister : tregister;
+         iregister : tregister;
+         jregister : tregister;
+         hp1 : treference;
+         hp2 : treference;
+         hl : plabel;
+      begin
+         hregister := getregister32;
+         if delsource then
+           del_reference(source);
+
+         { from 12 bytes movs is being used }
+         if (size<=8) or (not(cs_littlesize in aktswitches) and (size<=12)) then
+           begin
+              helpsize:=size div 4;
+              { move a dword x times }
+              for i:=1 to helpsize do
+                begin
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(source),hregister)));
+                   exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,hregister,newreference(dest))));
+                   inc(source.offset,4);
+                   inc(dest.offset,4);
+                   dec(size,4);
+                end;
+              { move a word }
+              if size>1 then
+                begin
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(source),hregister)));
+                   exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_W,hregister,newreference(dest))));
+                   inc(source.offset,2);
+                   inc(dest.offset,2);
+                   dec(size,2);
+                end;
+              { move a single byte }
+              if size>0 then
+                begin
+                  exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(source),hregister)));
+                  exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_B,hregister,newreference(dest))));
+                end
+
+           end
+           else
+           begin
+              if (usableaddress > 1) then
+                begin
+                    iregister := getaddressreg;
+                    jregister := getaddressreg;
+                end
+              else
+              if (usableaddress = 1) then
+                begin
+                    iregister := getaddressreg;
+                    jregister := R_A1;
+                end
+              else
+                begin
+                    iregister := R_A0;
+                    jregister := R_A1;
+                end;
+              { reference for move (An)+,(An)+ }
+              reset_reference(hp1);
+              hp1.base := iregister;   { source register }
+              hp1.direction := dir_inc;
+              reset_reference(hp2);
+              hp2.base := jregister;
+              hp1.direction := dir_inc;
+              { iregister = source }
+              { jregister = destination }
+              exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(source),iregister)));
+              exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(dest),jregister)));
+
+              { double word move }
+              helpsize := size - size mod 4;
+              size := size mod 4;
+              exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,helpsize div 4,hregister)));
+              getlabel(hl);
+              emitl(A_LABEL,hl);
+              exprasmlist^.concat(new(pai68k,op_ref_ref(A_MOVE,S_L,newreference(hp1),newreference(hp2))));
+              exprasmlist^.concat(new(pai68k,op_const_reg(A_SUBQ,S_L,4,hregister)));
+              emitl(A_BNE,hl);
+              if size > 1 then
+                begin
+                    dec(size,2);
+                    exprasmlist^.concat(new(pai68k,op_ref_ref(A_MOVE,S_W,newreference(hp1), newreference(hp2))));
+                end;
+              if size = 1 then
+                    exprasmlist^.concat(new(pai68k,op_ref_ref(A_MOVE,S_B,newreference(hp1), newreference(hp2))));
+       { restore the registers that we have just used olny if they are used! }
+          if jregister = R_A1 then
+            hp2.base := R_NO;
+          if iregister = R_A0 then
+            hp1.base := R_NO;
+          del_reference(hp1);
+          del_reference(hp2);
+           end;
+
+           { loading SELF-reference again }
+           maybe_loada5;
+
+           if delsource then
+               ungetiftemp(source);
+
+           ungetregister32(hregister);
+    end;
+
+
+    procedure emitloadord2reg(location:Tlocation;orddef:Porddef;
+                              destreg:Tregister;delloc:boolean);
+
+    {A lot smaller and less bug sensitive than the original unfolded loads.}
+
+    var tai:pai68k;
+        r:Preference;
+
+    begin
+        case location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+                begin
+                    case orddef^.typ of
+                        u8bit: begin
+                                 exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,location.register,destreg)));
+                                 exprasmlist^.concat(new(pai68k,op_const_reg(A_ANDI,S_L,$FF,destreg)));
+                               end;
+                        s8bit: begin
+                                 exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,location.register,destreg)));
+                                 if (opt_processors <> MC68020) then
+                                  begin
+                                 { byte to word }
+                                     exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_W,destreg)));
+                                 { word to long }
+                                     exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,destreg)));
+                                  end
+                                 else { 68020+ and later only }
+                                     exprasmlist^.concat(new(pai68k,op_reg(A_EXTB,S_L,destreg)));
+                                end;
+                        u16bit: begin
+                                 exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,location.register,destreg)));
+                                 exprasmlist^.concat(new(pai68k,op_const_reg(A_ANDI,S_L,$FFFF,destreg)));
+                                end;
+                        s16bit: begin
+                                 exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,location.register,destreg)));
+                                 { word to long }
+                                 exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,destreg)));
+                                end;
+                        u32bit:
+                            exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,location.register,destreg)));
+                        s32bit:
+                            exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,location.register,destreg)));
+                    end;
+                    if delloc then
+                        ungetregister(location.register);
+                end;
+            LOC_REFERENCE:
+                begin
+                    r:=newreference(location.reference);
+                    case orddef^.typ of
+                        u8bit: begin
+                                 exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,destreg)));
+                                 exprasmlist^.concat(new(pai68k,op_const_reg(A_ANDI,S_L,$FF,destreg)));
+                               end;
+                        s8bit:  begin
+                                 exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,r,destreg)));
+                                 if (opt_processors <> MC68020) then
+                                  begin
+                                 { byte to word }
+                                     exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_W,destreg)));
+                                 { word to long }
+                                     exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,destreg)));
+                                  end
+                                 else { 68020+ and later only }
+                                     exprasmlist^.concat(new(pai68k,op_reg(A_EXTB,S_L,destreg)));
+                                end;
+                        u16bit: begin
+                                 exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,r,destreg)));
+                                 exprasmlist^.concat(new(pai68k,op_const_reg(A_ANDI,S_L,$ffff,destreg)));
+                                end;
+                        s16bit: begin
+                                       exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,r,destreg)));
+                                 { word to long }
+                                 exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,destreg)));
+                                end;
+                        u32bit:
+                            exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,destreg)));
+                        s32bit:
+                            exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,destreg)));
+                    end;
+                    if delloc then
+                        del_reference(location.reference);
+                end
+            else
+                internalerror(6);
+        end;
+    end;
+
+
+    { if necessary A5 is reloaded after a call}
+    procedure maybe_loada5;
+
+      var
+         hp : preference;
+         p : pprocinfo;
+         i : longint;
+
+      begin
+         if assigned(procinfo._class) then
+           begin
+              if lexlevel>2 then
+                begin
+                   new(hp);
+                   reset_reference(hp^);
+                   hp^.offset:=procinfo.framepointer_offset;
+                   hp^.base:=procinfo.framepointer;
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,R_A5)));
+                   p:=procinfo.parent;
+                   for i:=3 to lexlevel-1 do
+                     begin
+                        new(hp);
+                        reset_reference(hp^);
+                        hp^.offset:=p^.framepointer_offset;
+                        hp^.base:=R_A5;
+                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,R_A5)));
+                        p:=p^.parent;
+                     end;
+                   new(hp);
+                   reset_reference(hp^);
+                   hp^.offset:=p^.ESI_offset;
+                   hp^.base:=R_A5;
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,R_A5)));
+                end
+              else
+                begin
+                   new(hp);
+                   reset_reference(hp^);
+                   hp^.offset:=procinfo.ESI_offset;
+                   hp^.base:=procinfo.framepointer;
+                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,R_A5)));
+                end;
+           end;
+      end;
+
+
+  (***********************************************************************)
+  (* PROCEDURE FLOATLOAD                                                 *)
+  (*  Description: This routine is to be called each time a location     *)
+  (*   must be set to LOC_FPU and a value loaded into a FPU register.    *)
+  (*                                                                     *)
+  (*  Remark: The routine sets up the register field of LOC_FPU correctly*)
+  (***********************************************************************)
+
+    procedure floatload(t : tfloattype;const ref : treference; var location:tlocation);
+
+      var
+         op : tasmop;
+         s : topsize;
+
+      begin
+        { no emulation }
+        case t of
+            s32real : s := S_S;
+            s64real : s := S_Q;
+            s80real : s := S_X;
+         else
+           begin
+             Message(cg_f_unknown_float_type);
+           end;
+        end; { end case }
+        location.loc := LOC_FPU;
+        if not ((cs_fp_emulation) in aktswitches) then
+        begin
+            location.fpureg := getfloatreg;
+            exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,s,newreference(ref),location.fpureg)))
+        end
+        else
+        { handle emulation }
+        begin
+          if t = s32real then
+          begin
+            location.fpureg := getregister32;
+            exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(ref),location.fpureg)))
+          end
+          else
+             { other floating types are not supported in emulation mode }
+            Message(sym_e_type_id_not_defined);
+        end;
+      end;
+
+{    procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize);
+
+      begin
+         case t of
+            s32real : begin
+                         op:=A_FSTP;
+                         s:=S_S;
+                      end;
+            s64real : begin
+                         op:=A_FSTP;
+                         s:=S_L;
+                      end;
+            s80real : begin
+                         op:=A_FSTP;
+                         s:=S_Q;
+                      end;
+            s64bit : begin
+                         op:=A_FISTP;
+                         s:=S_Q;
+                      end;
+            else internalerror(17);
+         end;
+      end; }
+
+
+    { stores an FPU value to memory }
+    { location:tlocation used to free up FPU register }
+    { ref: destination of storage                     }
+    procedure floatstore(t : tfloattype;var location:tlocation; const ref:treference);
+
+      var
+         op : tasmop;
+         s : topsize;
+
+      begin
+        if location.loc <> LOC_FPU then
+         InternalError(34);
+        { no emulation }
+        case t of
+            s32real : s := S_S;
+            s64real : s := S_Q;
+            s80real : s := S_X;
+         else
+           begin
+             Message(cg_f_unknown_float_type);
+           end;
+        end; { end case }
+        if not ((cs_fp_emulation) in aktswitches) then
+        begin
+            exprasmlist^.concat(new(pai68k,op_reg_ref(A_FMOVE,s,location.fpureg,newreference(ref))));
+            ungetregister(location.fpureg);
+        end
+        else
+        { handle emulation }
+        begin
+          if t = s32real then
+          begin
+            exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,location.fpureg,newreference(ref))));
+            ungetregister32(location.fpureg);
+          end
+          else
+             { other floating types are not supported in emulation mode }
+            Message(sym_e_type_id_not_defined);
+        end;
+        location.fpureg:=R_NO;  { no register in LOC_FPU now }
+      end;
+
+    procedure firstcomplex(p : ptree);
+
+      var
+         hp : ptree;
+
+      begin
+         { always calculate boolean AND and OR from left to right }
+         if ((p^.treetype=orn) or (p^.treetype=andn)) and
+           (p^.left^.resulttype^.deftype=orddef) and
+           (porddef(p^.left^.resulttype)^.typ=bool8bit) then
+           p^.swaped:=false
+         else if (p^.left^.registers32<p^.right^.registers32)
+
+           { the following check is appropriate, because all }
+           { 4 registers are rarely used and it is thereby   }
+           { achieved that the extra code is being dropped   }
+           { by exchanging not commutative operators         }
+           and (p^.right^.registers32<=4) then
+           begin
+              hp:=p^.left;
+              p^.left:=p^.right;
+              p^.right:=hp;
+              p^.swaped:=true;
+           end
+         else p^.swaped:=false;
+      end;
+
+    procedure secondfuncret(var p : ptree);
+
+      var
+         hregister : tregister;
+
+      begin
+         clear_reference(p^.location.reference);
+         p^.location.reference.base:=procinfo.framepointer;
+         p^.location.reference.offset:=procinfo.retoffset;
+         if ret_in_param(procinfo.retdef) then
+           begin
+              hregister:=getaddressreg;
+              exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVEA,S_L,newreference(p^.location.reference),hregister)));
+              p^.location.reference.base:=hregister;
+              p^.location.reference.offset:=0;
+           end;
+      end;
+
+    procedure codegen_newprocedure;
+
+      begin
+         aktbreaklabel:=nil;
+         aktcontinuelabel:=nil;
+         { aktexitlabel:=0; is store in oldaktexitlabel
+           so it must not be reset to zero before this storage !}
+
+         { the type of this lists isn't important }
+         { because the code of this lists is      }
+         { copied to the code segment             }
+         procinfo.aktentrycode:=new(paasmoutput,init);
+         procinfo.aktexitcode:=new(paasmoutput,init);
+         procinfo.aktproccode:=new(paasmoutput,init);
+      end;
+
+    procedure codegen_doneprocedure;
+
+      begin
+         dispose(procinfo.aktentrycode,done);
+         dispose(procinfo.aktexitcode,done);
+         dispose(procinfo.aktproccode,done);
+      end;
+
+    procedure codegen_newmodule;
+
+      begin
+         exprasmlist:=new(paasmoutput,init);
+      end;
+
+    procedure codegen_donemodule;
+
+      begin
+         dispose(exprasmlist,done);
+         dispose(codesegment,done);
+         dispose(bsssegment,done);
+         dispose(datasegment,done);
+         dispose(debuglist,done);
+         dispose(externals,done);
+         dispose(consts,done);
+      end;
+
+  end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:13  root
+  Initial revision
+
+  Revision 1.15  1998/03/22 12:45:38  florian
+    * changes of Carl-Eric to m68k target commit:
+      - wrong nodes because of the new string cg in intel, I had to create
+        this under m68k also ... had to work it out to fix potential alignment
+        problems --> this removes the crash of the m68k compiler.
+      - added absolute addressing in m68k assembler (required for Amiga startup)
+      - fixed alignment problems (because of byte return values, alignment
+        would not be always valid) -- is this ok if i change the offset if odd in
+        setfirsttemp ?? -- it seems ok...
+
+  Revision 1.14  1998/03/10 04:20:37  carl
+    * extdebug problems
+    - removed loadstring as it is not required for the m68k
+
+  Revision 1.13  1998/03/10 01:17:16  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.12  1998/03/09 10:44:35  peter
+    + string='', string<>'', string:='', string:=char optimizes (the first 2
+      were already in cg68k2)
+
+  Revision 1.11  1998/03/06 00:52:03  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.10  1998/03/03 04:12:04  carl
+    * moved generate routines to this unit
+
+  Revision 1.9  1998/03/02 01:48:17  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.8  1998/02/13 10:34:45  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.7  1998/02/12 11:49:50  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.6  1998/01/11 03:39:02  carl
+  * bugfix of concatcopy , was using wrong reference
+  * bugfix of MOVEQ
+
+  Revision 1.3  1997/12/09 13:30:05  carl
+  + renamed some stuff
+
+  Revision 1.2  1997/12/03 13:59:01  carl
+  + added emitcall as in i386 version.
+
+  Revision 1.1.1.1  1997/11/27 08:32:53  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
+
+  History:
+  27th september 1997:
+    + first version for MC68000 (using v093 template) (CEC)
+  9th october 1997:
+    * fixed a bug in push_int as well as other routines which used
+      getregister32 while they are not supposed to (because of how
+      the allocation of registers work in parser.pas) (CEC)
+    * Fixed some bugs in the concatcopy routine, was allocating
+      registers which were not supposed to be allocated. (CEC)
+
+}

compiler/cgi386.pas

@@ -0,0 +1,5934 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl
+
+    This unit generates i386 (or better) assembler from the parse tree
+
+    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.
+
+ ****************************************************************************
+}
+
+{$ifdef tp}
+{$E+,F+,N+,D+,L+,Y+}
+{$endif}
+unit cgi386;
+
+
+{***************************************************************************}
+interface
+{***************************************************************************}
+
+uses    objects,verbose,cobjects,systems,globals,tree,
+        symtable,types,strings,pass_1,hcodegen,
+        aasm,i386,tgeni386,files,cgai386
+{$ifdef GDB}
+        ,gdb
+{$endif GDB}
+{$ifdef TP}
+        ,cgi3862
+{$endif TP}
+        ;
+
+{ produces assembler for the expression in variable p }
+{ and produces an assembler node at the end           }
+procedure generatecode(var p : ptree);
+
+{ produces the actual code }
+function do_secondpass(var p : ptree) : boolean;
+
+procedure secondpass(var p : ptree);
+
+{$ifdef test_dest_loc}
+const   { used to avoid temporary assignments }
+        dest_loc_known : boolean = false;
+        in_dest_loc : boolean = false;
+        dest_loc_tree : ptree = nil;
+
+var dest_loc : tlocation;
+
+procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
+
+{$endif test_dest_loc}
+
+
+
+
+{***************************************************************************}
+implementation
+{***************************************************************************}
+
+    const
+       never_copy_const_param : boolean = false;
+
+{$ifdef test_dest_loc}
+       procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister);
+
+         begin
+            if (dest_loc.loc=LOC_CREGISTER) or (dest_loc.loc=LOC_REGISTER) then
+              begin
+                emit_reg_reg(A_MOV,s,reg,dest_loc.register);
+                p^.location:=dest_loc;
+                in_dest_loc:=true;
+              end
+            else
+            if (dest_loc.loc=LOC_REFERENCE) or (dest_loc.loc=LOC_MEM) then
+              begin
+                exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,s,reg,newreference(dest_loc.reference))));
+                p^.location:=dest_loc;
+                in_dest_loc:=true;
+              end
+            else
+              internalerror(20080);
+         end;
+
+{$endif test_dest_loc}
+
+     const
+       bytes2Sxx:array[1..4] of Topsize=(S_B,S_W,S_NO,S_L);
+
+    procedure error(const t : tmsgconst);
+
+      begin
+         if not(codegenerror) then
+           verbose.Message(t);
+         codegenerror:=true;
+      end;
+
+    type
+       secondpassproc = procedure(var p : ptree);
+
+    procedure seconderror(var p : ptree);
+
+      begin
+         p^.error:=true;
+         codegenerror:=true;
+      end;
+
+    var
+       { this is for open arrays and strings        }
+       { but be careful, this data is in the        }
+       { generated code destroyed quick, and also   }
+       { the next call of secondload destroys this  }
+       { data                                       }
+       { So be careful using the informations       }
+       { provided by this variables                 }
+       highframepointer : tregister;
+       highoffset : longint;
+
+{$ifndef TP}
+
+{$I cgi386ad.inc}
+
+{$endif TP}
+
+    procedure secondload(var p : ptree);
+
+      var
+         hregister : tregister;
+         symtabletype : tsymtabletype;
+         i : longint;
+         hp : preference;
+
+      begin
+         simple_loadn:=true;
+         reset_reference(p^.location.reference);
+         case p^.symtableentry^.typ of
+              { this is only for toasm and toaddr }
+              absolutesym :
+                 begin
+                    stringdispose(p^.location.reference.symbol);
+                    if (pabsolutesym(p^.symtableentry)^.abstyp=toaddr) then
+                     begin
+                       if pabsolutesym(p^.symtableentry)^.absseg then
+                        p^.location.reference.segment:=R_FS;
+                       p^.location.reference.offset:=pabsolutesym(p^.symtableentry)^.address;
+                     end
+                    else
+                     p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
+                    if p^.symtableentry^.owner^.symtabletype=unitsymtable then
+                      concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
+                 end;
+              varsym :
+                 begin
+                    hregister:=R_NO;
+                    symtabletype:=p^.symtable^.symtabletype;
+                    { in case it is a register variable: }
+                    if pvarsym(p^.symtableentry)^.reg<>R_NO then
+                      begin
+                         p^.location.loc:=LOC_CREGISTER;
+                         p^.location.register:=pvarsym(p^.symtableentry)^.reg;
+                         unused:=unused-[pvarsym(p^.symtableentry)^.reg];
+                      end
+                    else
+                      begin
+                         { first handle local and temporary variables }
+                         if (symtabletype=parasymtable) or (symtabletype=localsymtable) then
+                           begin
+                              p^.location.reference.base:=procinfo.framepointer;
+                              p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
+                              if (symtabletype=localsymtable) then
+                                p^.location.reference.offset:=-p^.location.reference.offset;
+                              if (symtabletype=parasymtable) then
+                                inc(p^.location.reference.offset,p^.symtable^.call_offset);
+                              if (lexlevel>(p^.symtable^.symtablelevel)) then
+                                begin
+                                   hregister:=getregister32;
+
+                                   { make a reference }
+                                   new(hp);
+                                   reset_reference(hp^);
+                                   hp^.offset:=procinfo.framepointer_offset;
+                                   hp^.base:=procinfo.framepointer;
+
+                                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister)));
+
+                                   simple_loadn:=false;
+                                   i:=lexlevel-1;
+                                   while i>(p^.symtable^.symtablelevel) do
+                                     begin
+                                        { make a reference }
+                                        new(hp);
+                                        reset_reference(hp^);
+                                        hp^.offset:=8;
+                                        hp^.base:=hregister;
+
+                                        exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister)));
+                                        dec(i);
+                                     end;
+                                   p^.location.reference.base:=hregister;
+                                end;
+                           end
+                         else
+                           case symtabletype of
+                              unitsymtable,globalsymtable,
+                              staticsymtable : begin
+                                                  stringdispose(p^.location.reference.symbol);
+                                                  p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
+                                                  if symtabletype=unitsymtable then
+                                                    concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
+                                               end;
+                              objectsymtable : begin
+                                                  if (pvarsym(p^.symtableentry)^.properties and sp_static)<>0 then
+                                                    begin
+                                                       stringdispose(p^.location.reference.symbol);
+                                                       p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
+                                                       if p^.symtable^.defowner^.owner^.symtabletype=unitsymtable then
+                                                         concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
+                                                    end
+                                                  else
+                                                    begin
+                                                       p^.location.reference.base:=R_ESI;
+                                                       p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
+                                                    end;
+                                               end;
+                              withsymtable:
+                                begin
+                                   hregister:=getregister32;
+                                   p^.location.reference.base:=hregister;
+                                   { make a reference }
+                                   new(hp);
+                                   reset_reference(hp^);
+                                   hp^.offset:=p^.symtable^.datasize;
+                                   hp^.base:=procinfo.framepointer;
+
+                                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister)));
+
+                                   p^.location.reference.offset:=
+                                     pvarsym(p^.symtableentry)^.address;
+                                end;
+                           end;
+                         { in case call by reference, then calculate: }
+                         if (pvarsym(p^.symtableentry)^.varspez=vs_var) or
+                            ((pvarsym(p^.symtableentry)^.varspez=vs_const) and
+                             dont_copy_const_param(pvarsym(p^.symtableentry)^.definition)) then
+                           begin
+                              simple_loadn:=false;
+                              if hregister=R_NO then
+                                hregister:=getregister32;
+                              if (p^.location.reference.base=procinfo.framepointer) then
+                                begin
+                                   highframepointer:=p^.location.reference.base;
+                                   highoffset:=p^.location.reference.offset;
+                                end
+                              else
+                                begin
+                                   highframepointer:=R_EDI;
+                                   highoffset:=p^.location.reference.offset;
+                                   exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,
+                                     p^.location.reference.base,R_EDI)));
+                                end;
+                              exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),
+                                hregister)));
+                              clear_reference(p^.location.reference);
+                              p^.location.reference.base:=hregister;
+                          end;
+                         {
+                         if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and
+                           ((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oois_class)<>0) then
+                           begin
+                              simple_loadn:=false;
+                              if hregister=R_NO then
+                                hregister:=getregister32;
+                              exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),
+                                hregister)));
+                              clear_reference(p^.location.reference);
+                              p^.location.reference.base:=hregister;
+                           end;
+                         }
+                      end;
+                 end;
+              procsym:
+                 begin
+                    {!!!!! Be aware, work on virtual methods too }
+                    stringdispose(p^.location.reference.symbol);
+                    p^.location.reference.symbol:=
+                      stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname);
+                    if p^.symtable^.symtabletype=unitsymtable then
+                      concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
+                 end;
+              typedconstsym :
+                 begin
+                    stringdispose(p^.location.reference.symbol);
+                    p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
+                    if p^.symtable^.symtabletype=unitsymtable then
+                    concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
+                 end;
+              else internalerror(4);
+         end;
+      end;
+
+    procedure secondmoddiv(var p : ptree);
+
+      var
+         hreg1 : tregister;
+         pushed,popeax,popedx : boolean;
+         power : longint;
+         hl : plabel;
+
+      begin
+         secondpass(p^.left);
+         set_location(p^.location,p^.left^.location);
+         pushed:=maybe_push(p^.right^.registers32,p);
+         secondpass(p^.right);
+         if pushed then restore(p);
+
+         { put numerator in register }
+         if p^.left^.location.loc<>LOC_REGISTER then
+           begin
+              if p^.left^.location.loc=LOC_CREGISTER then
+                begin
+                  hreg1:=getregister32;
+                  emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hreg1);
+                end
+              else
+                begin
+                  del_reference(p^.left^.location.reference);
+                  hreg1:=getregister32;
+                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
+                    hreg1)));
+                end;
+              p^.left^.location.loc:=LOC_REGISTER;
+              p^.left^.location.register:=hreg1;
+           end
+         else hreg1:=p^.left^.location.register;
+
+           if (p^.treetype=divn) and (p^.right^.treetype=ordconstn) and
+               ispowerof2(p^.right^.value,power) then
+             begin
+                 exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L,hreg1,hreg1)));
+                 getlabel(hl);
+                 emitl(A_JNS,hl);
+                 if power=1 then
+                    exprasmlist^.concat(new(pai386,op_reg(A_INC,S_L,hreg1)))
+                 else exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,p^.right^.value-1,hreg1)));
+
+                 emitl(A_LABEL,hl);
+                 exprasmlist^.concat(new(pai386,op_const_reg(A_SAR,S_L,power,hreg1)));
+             end
+           else
+             begin
+                 { bring denominator to EDI }
+                 { EDI is always free, it's }
+                 { only used for temporary  }
+                 { purposes                 }
+                 if (p^.right^.location.loc<>LOC_REGISTER) and
+                     (p^.right^.location.loc<>LOC_CREGISTER) then
+                    begin
+                       del_reference(p^.right^.location.reference);
+                       p^.left^.location.loc:=LOC_REGISTER;
+                       exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),R_EDI)));
+                end
+              else
+                begin
+                   ungetregister32(p^.right^.location.register);
+                   emit_reg_reg(A_MOV,S_L,p^.right^.location.register,R_EDI);
+                end;
+              popedx:=false;
+              popeax:=false;
+              if hreg1=R_EDX then
+                begin
+                       if not(R_EAX in unused) then
+                     begin
+                        exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EAX)));
+                        popeax:=true;
+                     end;
+                   emit_reg_reg(A_MOV,S_L,R_EDX,R_EAX);
+                end
+                 else
+                begin
+                   if not(R_EDX in unused) then
+                     begin
+                              exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EDX)));
+                        popedx:=true;
+                     end;
+                   if hreg1<>R_EAX then
+                     begin
+                        if not(R_EAX in unused) then
+                          begin
+                             exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EAX)));
+                             popeax:=true;
+                          end;
+                        emit_reg_reg(A_MOV,S_L,hreg1,R_EAX);
+                     end;
+                end;
+              exprasmlist^.concat(new(pai386,op_none(A_CLTD,S_NO)));
+                 exprasmlist^.concat(new(pai386,op_reg(A_IDIV,S_L,R_EDI)));
+                 if p^.treetype=divn then
+                begin
+                   { if result register is busy then copy }
+                   if popeax then
+                     begin
+                        if hreg1=R_EAX then
+                          internalerror(112);
+                        emit_reg_reg(A_MOV,S_L,R_EAX,hreg1)
+                     end
+                   else
+                          if hreg1<>R_EAX then
+                       emit_reg_reg(A_MOV,S_L,R_EAX,hreg1);
+                end
+              else
+                emit_reg_reg(A_MOV,S_L,R_EDX,hreg1);
+              if popeax then
+                exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EAX)));
+              if popedx then
+                    exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDX)));
+             end;
+           { this registers are always used when div/mod are present }
+         usedinproc:=usedinproc or ($80 shr byte(R_EAX));
+         usedinproc:=usedinproc or ($80 shr byte(R_EDX));
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=hreg1;
+      end;
+
+    procedure secondshlshr(var p : ptree);
+
+      var
+         hregister1,hregister2,hregister3 : tregister;
+         pushed,popecx : boolean;
+         op : tasmop;
+
+      begin
+         popecx:=false;
+
+         secondpass(p^.left);
+         pushed:=maybe_push(p^.right^.registers32,p);
+         secondpass(p^.right);
+         if pushed then restore(p);
+
+         { load left operators in a register }
+         if p^.left^.location.loc<>LOC_REGISTER then
+           begin
+              if p^.left^.location.loc=LOC_CREGISTER then
+                begin
+                   hregister1:=getregister32;
+                   emit_reg_reg(A_MOV,S_L,p^.left^.location.register,
+                     hregister1);
+                end
+              else
+                begin
+                   del_reference(p^.left^.location.reference);
+                   hregister1:=getregister32;
+                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
+                     hregister1)));
+                end;
+           end
+           else hregister1:=p^.left^.location.register;
+
+         { determine operator }
+         if p^.treetype=shln then
+           op:=A_SHL
+         else
+           op:=A_SHR;
+
+         { shifting by a constant directly decode: }
+         if (p^.right^.treetype=ordconstn) then
+           begin
+                 exprasmlist^.concat(new(pai386,op_const_reg(op,S_L,p^.right^.location.reference.offset and 31,
+                hregister1)));
+              p^.location.loc:=LOC_REGISTER;
+              p^.location.register:=hregister1;
+           end
+         else
+           begin
+              { load right operators in a register }
+              if p^.right^.location.loc<>LOC_REGISTER then
+                begin
+                       if p^.right^.location.loc=LOC_CREGISTER then
+                     begin
+                              hregister2:=getregister32;
+                        emit_reg_reg(A_MOV,S_L,p^.right^.location.register,
+                          hregister2);
+                     end
+                   else
+                     begin
+                        del_reference(p^.right^.location.reference);
+                        hregister2:=getregister32;
+                        exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),
+                          hregister2)));
+                     end;
+                end
+              else hregister2:=p^.right^.location.register;
+
+                 { left operator is already in a register }
+              { hence are both in a register }
+              { is it in the case ECX ? }
+              if (hregister1=R_ECX) then
+                begin
+                   { then only swap }
+                   emit_reg_reg(A_XCHG,S_L,hregister1,
+                     hregister2);
+
+                   hregister3:=hregister1;
+                   hregister1:=hregister2;
+                   hregister2:=hregister3;
+                end
+              { if second operator not in ECX ? }
+              else if (hregister2<>R_ECX) then
+                begin
+                   { ECX not occupied then swap with right register }
+                   if R_ECX in unused then
+                     begin
+                        emit_reg_reg(A_MOV,S_L,hregister2,R_ECX);
+                        ungetregister32(hregister2);
+                          end
+                       else
+                     begin
+                        { else save ECX and then copy it }
+                        popecx:=true;
+                        exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ECX)));
+                        emit_reg_reg(A_MOV,S_L,hregister2,R_ECX);
+                        ungetregister32(hregister2);
+                     end;
+                end;
+              { right operand is in ECX }
+              emit_reg_reg(op,S_L,R_CL,hregister1);
+              { maybe ECX back }
+              if popecx then
+                exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_ECX)));
+              p^.location.register:=hregister1;
+             end;
+         { this register is always used when shl/shr are present }
+         usedinproc:=usedinproc or ($80 shr byte(R_ECX));
+      end;
+
+    procedure secondrealconst(var p : ptree);
+
+      var
+         hp1 : pai;
+         lastlabel : plabel;
+         found : boolean;
+
+      begin
+         clear_reference(p^.location.reference);
+         lastlabel:=nil;
+         found:=false;
+         { const already used ? }
+         if p^.labnumber=-1 then
+           begin
+              { tries to found an old entry }
+              hp1:=pai(consts^.first);
+              while assigned(hp1) do
+                begin
+                   if hp1^.typ=ait_label then
+                     lastlabel:=pai_label(hp1)^.l
+                   else
+                     begin
+                        if (hp1^.typ=p^.realtyp) and (lastlabel<>nil) then
+                          begin
+                             { Florian this caused a internalerror(10)=> no free reg !! }
+                             {if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) or
+                               ((p^.realtyp=ait_real_80bit) and (pai_extended(hp1)^.value=p^.valued)) or
+                               ((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then }
+                             if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) then
+                               found:=true;
+                             if ((p^.realtyp=ait_real_extended) and (pai_extended(hp1)^.value=p^.valued)) then
+                               found:=true;
+                             if ((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then
+                               found:=true;
+                             if found then
+                               begin
+                                  { found! }
+                                  p^.labnumber:=lastlabel^.nb;
+                                  break;
+                               end;
+                          end;
+                        lastlabel:=nil;
+                     end;
+                   hp1:=pai(hp1^.next);
+                end;
+              { :-(, we must generate a new entry }
+                 if p^.labnumber=-1 then
+                begin
+                   getlabel(lastlabel);
+                   p^.labnumber:=lastlabel^.nb;
+                   case p^.realtyp of
+                     ait_real_64bit : consts^.insert(new(pai_double,init(p^.valued)));
+                     ait_real_32bit : consts^.insert(new(pai_single,init(p^.valued)));
+                     ait_real_extended : consts^.insert(new(pai_extended,init(p^.valued)));
+                     else
+                       internalerror(10120);
+                     end;
+{$ifndef MAKELIB}
+                   consts^.insert(new(pai_label,init(lastlabel)));
+{$else MAKELIB}
+                   consts^.insert(new(pai_symbol,init_global('$'+current_module^.name^
+                     +'$real_const'+tostr(p^.labnumber))));
+                   consts^.insert(new(pai_cut,init));
+{$endif MAKELIB}
+                end;
+           end;
+         stringdispose(p^.location.reference.symbol);
+{$ifndef MAKELIB}
+         p^.location.reference.symbol:=stringdup(lab2str(lastlabel));
+{$else MAKELIB}
+         p^.location.reference.symbol:=stringdup('$'+current_module^.name^
+                     +'$real_const'+tostr(p^.labnumber));
+{$endif MAKELIB}
+      end;
+
+    procedure secondfixconst(var p : ptree);
+
+      begin
+         { an fix comma const. behaves as a memory reference }
+         p^.location.loc:=LOC_MEM;
+         p^.location.reference.isintvalue:=true;
+         p^.location.reference.offset:=p^.valuef;
+      end;
+
+    procedure secondordconst(var p : ptree);
+
+      begin
+         { an integer const. behaves as a memory reference }
+         p^.location.loc:=LOC_MEM;
+         p^.location.reference.isintvalue:=true;
+         p^.location.reference.offset:=p^.value;
+      end;
+
+    procedure secondniln(var p : ptree);
+
+      begin
+         p^.location.loc:=LOC_MEM;
+         p^.location.reference.isintvalue:=true;
+         p^.location.reference.offset:=0;
+      end;
+
+    procedure secondstringconst(var p : ptree);
+
+      var
+         hp1 : pai;
+         lastlabel : plabel;
+         pc : pchar;
+         same_string : boolean;
+         i : word;
+
+      begin
+         clear_reference(p^.location.reference);
+         lastlabel:=nil;
+         { const already used ? }
+         if p^.labstrnumber=-1 then
+           begin
+              { tries to found an old entry }
+              hp1:=pai(consts^.first);
+              while assigned(hp1) do
+                begin
+                   if hp1^.typ=ait_label then
+                     lastlabel:=pai_label(hp1)^.l
+                   else
+                     begin
+                        if (hp1^.typ=ait_string) and (lastlabel<>nil) and
+                          (pai_string(hp1)^.len=length(p^.values^)+2) then
+                          begin
+                             same_string:=true;
+                             for i:=1 to length(p^.values^) do
+                               if pai_string(hp1)^.str[i]<>p^.values^[i] then
+                                 begin
+                                    same_string:=false;
+                                    break;
+                                 end;
+                             if same_string then
+                               begin
+                                  { found! }
+                                  p^.labstrnumber:=lastlabel^.nb;
+                                  break;
+                               end;
+                          end;
+                        lastlabel:=nil;
+                     end;
+                   hp1:=pai(hp1^.next);
+                end;
+              { :-(, we must generate a new entry }
+              if p^.labstrnumber=-1 then
+                begin
+                   getlabel(lastlabel);
+                   p^.labstrnumber:=lastlabel^.nb;
+                   getmem(pc,length(p^.values^)+3);
+                   move(p^.values^,pc^,length(p^.values^)+1);
+                   pc[length(p^.values^)+1]:=#0;
+                   { we still will have a problem if there is a #0 inside the pchar }
+                   consts^.insert(new(pai_string,init_pchar(pc)));
+                   { to overcome this problem we set the length explicitly }
+                   { with the ending null char }
+                   pai_string(consts^.first)^.len:=length(p^.values^)+2;
+{$ifndef MAKELIB}
+                   consts^.insert(new(pai_label,init(lastlabel)));
+{$else MAKELIB}
+                   consts^.insert(new(pai_symbol,init_global('$'+current_module^.name^
+                     +'$string_const'+tostr(p^.labstrnumber))));
+                   consts^.insert(new(pai_cut,init));
+{$endif MAKELIB}
+                end;
+           end;
+         stringdispose(p^.location.reference.symbol);
+{$ifndef MAKELIB}
+         p^.location.reference.symbol:=stringdup(lab2str(lastlabel));
+{$else MAKELIB}
+         p^.location.reference.symbol:=stringdup('$'+current_module^.name^
+                     +'$string_const'+tostr(p^.labstrnumber));
+{$endif MAKELIB}
+         p^.location.loc := LOC_MEM;
+      end;
+
+    procedure secondumminus(var p : ptree);
+
+{$ifdef SUPPORT_MMX}
+      procedure do_mmx_neg;
+
+        var
+           op : tasmop;
+
+        begin
+           p^.location.loc:=LOC_MMXREGISTER;
+           if cs_mmx_saturation in aktswitches then
+             case mmx_type(p^.resulttype) of
+                mmxs8bit:
+                  op:=A_PSUBSB;
+                mmxu8bit:
+                  op:=A_PSUBUSB;
+                mmxs16bit,mmxfixed16:
+                  op:=A_PSUBSW;
+                mmxu16bit:
+                  op:=A_PSUBUSW;
+             end
+           else
+             case mmx_type(p^.resulttype) of
+                mmxs8bit,mmxu8bit:
+                  op:=A_PSUBB;
+                mmxs16bit,mmxu16bit,mmxfixed16:
+                  op:=A_PSUBW;
+                mmxs32bit,mmxu32bit:
+                  op:=A_PSUBD;
+             end;
+           emit_reg_reg(op,S_NO,p^.location.register,R_MM7);
+           emit_reg_reg(A_MOVQ,S_NO,R_MM7,p^.location.register);
+        end;
+{$endif}
+
+      begin
+         secondpass(p^.left);
+         p^.location.loc:=LOC_REGISTER;
+         case p^.left^.location.loc of
+            LOC_REGISTER:
+              begin
+                 p^.location.register:=p^.left^.location.register;
+                 exprasmlist^.concat(new(pai386,op_reg(A_NEG,S_L,p^.location.register)));
+              end;
+            LOC_CREGISTER:
+              begin
+                 p^.location.register:=getregister32;
+                 emit_reg_reg(A_MOV,S_L,p^.location.register,
+                   p^.location.register);
+                 exprasmlist^.concat(new(pai386,op_reg(A_NEG,S_L,p^.location.register)));
+              end;
+{$ifdef SUPPORT_MMX}
+            LOC_MMXREGISTER:
+              begin
+                 p^.location:=p^.left^.location;
+                 emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7);
+                 do_mmx_neg;
+              end;
+            LOC_CMMXREGISTER:
+              begin
+                 p^.location.register:=getregistermmx;
+                 emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7);
+                 emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register,
+                   p^.location.register);
+                 do_mmx_neg;
+              end;
+{$endif SUPPORT_MMX}
+            LOC_REFERENCE,LOC_MEM:
+                           begin
+                              del_reference(p^.left^.location.reference);
+                              if (p^.left^.resulttype^.deftype=floatdef) and
+                                 (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then
+                                begin
+                                   p^.location.loc:=LOC_FPU;
+                                   floatload(pfloatdef(p^.left^.resulttype)^.typ,
+                                     p^.left^.location.reference);
+                                   exprasmlist^.concat(new(pai386,op_none(A_FCHS,S_NO)));
+                                end
+{$ifdef SUPPORT_MMX}
+                              else if (cs_mmx in aktswitches) and is_mmx_able_array(p^.left^.resulttype) then
+                                begin
+                                   p^.location.register:=getregistermmx;
+                                   emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7);
+                                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVQ,S_NO,
+                                     newreference(p^.left^.location.reference),
+                                     p^.location.register)));
+                                   do_mmx_neg;
+                                end
+{$endif SUPPORT_MMX}
+                              else
+                                begin
+                                   p^.location.register:=getregister32;
+                                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                                     newreference(p^.left^.location.reference),
+                                     p^.location.register)));
+                                   exprasmlist^.concat(new(pai386,op_reg(A_NEG,S_L,p^.location.register)));
+                                end;
+                           end;
+            LOC_FPU:
+              begin
+                 p^.location.loc:=LOC_FPU;
+                 exprasmlist^.concat(new(pai386,op_none(A_FCHS,S_NO)));
+              end;
+         end;
+         emitoverflowcheck;
+      end;
+
+    procedure secondaddr(var p : ptree);
+
+      begin
+         secondpass(p^.left);
+         p^.location.loc:=LOC_REGISTER;
+         del_reference(p^.left^.location.reference);
+         p^.location.register:=getregister32;
+         {@ on a procvar means returning an address to the procedure that
+           is stored in it.}
+         { yes but p^.left^.symtableentry can be nil
+           for example on @self !! }
+         { symtableentry can be also invalid, if left is no tree node }
+         if (p^.left^.treetype=loadn) and
+           assigned(p^.left^.symtableentry) and
+           (p^.left^.symtableentry^.typ=varsym) and
+           (pvarsym(p^.left^.symtableentry)^.definition^.deftype=procvardef) then
+           exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+             newreference(p^.left^.location.reference),
+             p^.location.register)))
+         else
+           exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
+             newreference(p^.left^.location.reference),
+             p^.location.register)));
+           { for use of other segments }
+           if p^.left^.location.reference.segment<>R_DEFAULT_SEG then
+             p^.location.segment:=p^.left^.location.reference.segment;
+      end;
+
+    procedure seconddoubleaddr(var p : ptree);
+
+      begin
+         secondpass(p^.left);
+         p^.location.loc:=LOC_REGISTER;
+         del_reference(p^.left^.location.reference);
+         p^.location.register:=getregister32;
+         exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
+         newreference(p^.left^.location.reference),
+           p^.location.register)));
+      end;
+
+    procedure secondnot(var p : ptree);
+
+      const
+         flagsinvers : array[F_E..F_BE] of tresflags =
+            (F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C,
+             F_A,F_AE,F_B,F_BE);
+
+      var
+         hl : plabel;
+
+      begin
+         if (p^.resulttype^.deftype=orddef) and
+            (porddef(p^.resulttype)^.typ=bool8bit) then
+              begin
+                 case p^.location.loc of
+                    LOC_JUMP : begin
+                                  hl:=truelabel;
+                                  truelabel:=falselabel;
+                                  falselabel:=hl;
+                                  secondpass(p^.left);
+                                  maketojumpbool(p^.left);
+                                  hl:=truelabel;
+                                  truelabel:=falselabel;
+                                  falselabel:=hl;
+                               end;
+                    LOC_FLAGS : begin
+                                   secondpass(p^.left);
+                                   p^.location.resflags:=flagsinvers[p^.left^.location.resflags];
+                                end;
+                    LOC_REGISTER : begin
+                                      secondpass(p^.left);
+                                      p^.location.register:=p^.left^.location.register;
+                                      exprasmlist^.concat(new(pai386,op_const_reg(A_XOR,S_B,1,p^.location.register)));
+                                   end;
+                    LOC_CREGISTER : begin
+                                       secondpass(p^.left);
+                                       p^.location.loc:=LOC_REGISTER;
+                                       p^.location.register:=reg32toreg8(getregister32);
+                                       emit_reg_reg(A_MOV,S_B,p^.left^.location.register,
+                                         p^.location.register);
+                                       exprasmlist^.concat(new(pai386,op_const_reg(A_XOR,S_B,1,p^.location.register)));
+                                    end;
+                    LOC_REFERENCE,LOC_MEM : begin
+                                              secondpass(p^.left);
+                                              del_reference(p^.left^.location.reference);
+                                              p^.location.loc:=LOC_REGISTER;
+                                              p^.location.register:=reg32toreg8(getregister32);
+                                              if p^.left^.location.loc=LOC_CREGISTER then
+                                                emit_reg_reg(A_MOV,S_B,p^.left^.location.register,
+                                                   p^.location.register)
+                                              else
+                                                exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_B,
+                                              newreference(p^.left^.location.reference),
+                                                p^.location.register)));
+                                              exprasmlist^.concat(new(pai386,op_const_reg(A_XOR,S_B,1,p^.location.register)));
+                                           end;
+                 end;
+              end
+{$ifdef SUPPORT_MMX}
+            else if (cs_mmx in aktswitches) and is_mmx_able_array(p^.left^.resulttype) then
+              begin
+                 secondpass(p^.left);
+                 p^.location.loc:=LOC_MMXREGISTER;
+                 { prepare EDI }
+                 exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_L,$ffffffff,R_EDI)));
+                 { load operand }
+                 case p^.left^.location.loc of
+                    LOC_MMXREGISTER:
+                      p^.location:=p^.left^.location;
+                    LOC_CMMXREGISTER:
+                      begin
+                         p^.location.register:=getregistermmx;
+                         emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register,
+                           p^.location.register);
+                      end;
+                    LOC_REFERENCE,LOC_MEM:
+                      begin
+                         del_reference(p^.left^.location.reference);
+                         p^.location.register:=getregistermmx;
+                         exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVQ,S_NO,
+                           newreference(p^.left^.location.reference),
+                           p^.location.register)));
+                      end;
+                 end;
+                 { load mask }
+                 emit_reg_reg(A_MOV,S_D,R_EDI,R_MM7);
+                 { lower 32 bit }
+                 emit_reg_reg(A_PXOR,S_D,R_MM7,p^.location.register);
+                 { shift mask }
+                 exprasmlist^.concat(new(pai386,op_const_reg(A_PSLLQ,S_NO,
+                   32,R_MM7)));
+                 { higher 32 bit }
+                 emit_reg_reg(A_PXOR,S_D,R_MM7,p^.location.register);
+              end
+{$endif SUPPORT_MMX}
+            else
+              begin
+                secondpass(p^.left);
+                p^.location.loc:=LOC_REGISTER;
+
+                case p^.left^.location.loc of
+                   LOC_REGISTER : begin
+                                     p^.location.register:=p^.left^.location.register;
+                                     exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register)));
+                                  end;
+                   LOC_CREGISTER : begin
+                                     p^.location.register:=getregister32;
+                                     emit_reg_reg(A_MOV,S_L,p^.left^.location.register,
+                                       p^.location.register);
+                                     exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register)));
+                                   end;
+                   LOC_REFERENCE,LOC_MEM :
+                                  begin
+                                     del_reference(p^.left^.location.reference);
+                                     p^.location.register:=getregister32;
+                                     exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                                       newreference(p^.left^.location.reference),
+                                       p^.location.register)));
+                                     exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register)));
+                                  end;
+                end;
+                {if  p^.left^.location.loc=loc_register then
+                  p^.location.register:=p^.left^.location.register
+                else
+                  begin
+                     del_locref(p^.left^.location);
+                     p^.location.register:=getregister32;
+                     exprasmlist^.concat(new(pai386,op_loc_reg(A_MOV,S_L,
+                       p^.left^.location,
+                       p^.location.register)));
+                  end;
+                exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register)));}
+
+             end;
+      end;
+
+    procedure secondnothing(var p : ptree);
+
+      begin
+      end;
+
+    procedure secondderef(var p : ptree);
+
+      var
+         hr : tregister;
+
+      begin
+         secondpass(p^.left);
+         clear_reference(p^.location.reference);
+         case p^.left^.location.loc of
+            LOC_REGISTER:
+              p^.location.reference.base:=p^.left^.location.register;
+            LOC_CREGISTER:
+              begin
+                 { ... and reserve one for the pointer }
+                 hr:=getregister32;
+                 emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr);
+                 p^.location.reference.base:=hr;
+              end;
+            else
+              begin
+                 { free register }
+                 del_reference(p^.left^.location.reference);
+
+                 { ...and reserve one for the pointer }
+                 hr:=getregister32;
+                 exprasmlist^.concat(new(pai386,op_ref_reg(
+                   A_MOV,S_L,newreference(p^.left^.location.reference),
+                   hr)));
+                 p^.location.reference.base:=hr;
+              end;
+         end;
+      end;
+
+    procedure secondvecn(var p : ptree);
+
+      var
+         pushed : boolean;
+         ind,hr : tregister;
+         _p : ptree;
+
+       function get_mul_size:longint;
+         begin
+           if p^.memindex then
+             get_mul_size:=1
+           else
+             get_mul_size:=p^.resulttype^.size;
+         end;
+
+
+      procedure calc_emit_mul;
+
+        var
+           l1,l2 : longint;
+
+          begin
+           l1:=get_mul_size;
+           case l1 of
+              1,2,4,8 : p^.location.reference.scalefactor:=l1;
+           else
+                begin
+                   if ispowerof2(l1,l2) then
+                     exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,l2,ind)))
+                   else
+                     exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,S_L,l1,ind)));
+                end;
+           end;
+        end;
+
+      var
+         extraoffset : longint;
+           t : ptree;
+           hp : preference;
+           tai:Pai386;
+
+      begin
+         secondpass(p^.left);
+         set_location(p^.location,p^.left^.location);
+
+         { offset can only differ from 0 if arraydef }
+         if p^.left^.resulttype^.deftype=arraydef then
+           dec(p^.location.reference.offset,
+               get_mul_size*parraydef(p^.left^.resulttype)^.lowrange);
+         if p^.right^.treetype=ordconstn then
+           begin
+              { offset can only differ from 0 if arraydef }
+              if (p^.left^.resulttype^.deftype=arraydef) then
+                begin
+                   if not(is_open_array(p^.left^.resulttype)) then
+                         begin
+                        if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or
+                           (p^.right^.value<parraydef(p^.left^.resulttype)^.lowrange) then
+                          Message(parser_e_range_check_error);
+
+                        dec(p^.left^.location.reference.offset,
+                            get_mul_size*parraydef(p^.left^.resulttype)^.lowrange);
+                         end
+                   else
+                     begin
+                        { range checking for open arrays }
+                     end;
+                end;
+              inc(p^.left^.location.reference.offset,
+                  get_mul_size*p^.right^.value);
+              if p^.memseg then
+                p^.left^.location.reference.segment:=R_FS;
+              p^.left^.resulttype:=p^.resulttype;
+              disposetree(p^.right);
+              _p:=p^.left;
+              putnode(p);
+              p:=_p;
+           end
+         else
+           begin
+                 { quick hack, to overcome Delphi 2 }
+              if (cs_maxoptimieren in aktswitches) and
+                (p^.left^.resulttype^.deftype=arraydef) then
+                begin
+                   extraoffset:=0;
+                   if (p^.right^.treetype=addn) then
+                     begin
+                        if p^.right^.right^.treetype=ordconstn then
+                          begin
+                             extraoffset:=p^.right^.right^.value;
+                             t:=p^.right^.left;
+                             putnode(p^.right);
+                             putnode(p^.right^.right);
+                             p^.right:=t
+                          end
+                        else if p^.right^.left^.treetype=ordconstn then
+                          begin
+                             extraoffset:=p^.right^.left^.value;
+                             t:=p^.right^.right;
+                                           putnode(p^.right);
+                             putnode(p^.right^.left);
+                             p^.right:=t
+                          end;
+                     end
+                   else if (p^.right^.treetype=subn) then
+                     begin
+                                    if p^.right^.right^.treetype=ordconstn then
+                          begin
+                             extraoffset:=p^.right^.right^.value;
+                             t:=p^.right^.left;
+                             putnode(p^.right);
+                             putnode(p^.right^.right);
+                             p^.right:=t
+                          end
+                        else if p^.right^.left^.treetype=ordconstn then
+                          begin
+                             extraoffset:=p^.right^.left^.value;
+                                           t:=p^.right^.right;
+                             putnode(p^.right);
+                             putnode(p^.right^.left);
+                             p^.right:=t
+                          end;
+                     end;
+                   inc(p^.location.reference.offset,
+                       get_mul_size*extraoffset);
+                end;
+              { calculate from left to right }
+              if (p^.location.loc<>LOC_REFERENCE) and
+                 (p^.location.loc<>LOC_MEM) then
+                Message(cg_e_illegal_expression);
+              pushed:=maybe_push(p^.right^.registers32,p);
+              secondpass(p^.right);
+              if pushed then restore(p);
+                case p^.right^.location.loc of
+                   LOC_REGISTER:
+                     begin
+                        ind:=p^.right^.location.register;
+                        case p^.right^.resulttype^.size of
+                           1:
+                             begin
+                                hr:=reg8toreg32(ind);
+                                emit_reg_reg(A_MOVZX,S_BL,ind,hr);
+                                ind:=hr;
+                             end;
+                           2:
+                             begin
+                                hr:=reg16toreg32(ind);
+                                emit_reg_reg(A_MOVZX,S_WL,ind,hr);
+                                 ind:=hr;
+                             end;
+                        end;
+                     end;
+                   LOC_CREGISTER:
+                     begin
+                        ind:=getregister32;
+                        case p^.right^.resulttype^.size of
+                           1:
+                             emit_reg_reg(A_MOVZX,S_BL,p^.right^.location.register,ind);
+                           2:
+                             emit_reg_reg(A_MOVZX,S_WL,p^.right^.location.register,ind);
+                           4:
+                             emit_reg_reg(A_MOV,S_L,p^.right^.location.register,ind);
+                        end;
+                     end;
+                   LOC_FLAGS:
+                     begin
+                        ind:=getregister32;
+                        exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_NO,reg32toreg8(ind))));
+                        emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind);
+                     end
+                   else
+                      begin
+                         del_reference(p^.right^.location.reference);
+                         ind:=getregister32;
+                         { Booleans are stored in an 8 bit memory location, so
+                           the use of MOVL is not correct }
+                         case p^.right^.resulttype^.size of
+                           1:
+                             tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind));
+                           2:
+                             tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind));
+                           4:
+                             tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind));
+                         end;
+                         exprasmlist^.concat(tai);
+                      end;
+                end;
+              { produce possible range check code: }
+              if cs_rangechecking in aktswitches  then
+                begin
+                   if p^.left^.resulttype^.deftype=arraydef then
+                     begin
+                        new(hp);
+                        reset_reference(hp^);
+                        parraydef(p^.left^.resulttype)^.genrangecheck;
+                        hp^.symbol:=stringdup('R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr));
+                        exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,ind,hp)));
+                     end;
+                end;
+              if p^.location.reference.index=R_NO then
+                begin
+                   p^.location.reference.index:=ind;
+                   calc_emit_mul;
+                end
+              else
+                begin
+                   if p^.location.reference.base=R_NO then
+                     begin
+                        case p^.location.reference.scalefactor of
+                           2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index)));
+                           4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index)));
+                           8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index)));
+                        end;
+                        calc_emit_mul;
+                        p^.location.reference.base:=p^.location.reference.index;
+                        p^.location.reference.index:=ind;
+                     end
+                   else
+                     begin
+                        exprasmlist^.concat(new(pai386,op_ref_reg(
+                          A_LEA,S_L,newreference(p^.location.reference),
+                          p^.location.reference.index)));
+                        ungetregister32(p^.location.reference.base);
+                        { the symbol offset is loaded,               }
+                        { so release the symbol name and set symbol  }
+                        { to nil                                     }
+                        stringdispose(p^.location.reference.symbol);
+                        p^.location.reference.offset:=0;
+                        calc_emit_mul;
+                        p^.location.reference.base:=p^.location.reference.index;
+                        p^.location.reference.index:=ind;
+                     end;
+                end;
+             if p^.memseg then
+               p^.location.reference.segment:=R_FS;
+           end;
+      end;
+
+    { *************** Converting Types **************** }
+
+    { produces if necessary rangecheckcode }
+
+     procedure maybe_rangechecking(p : ptree;p2,p1 : pdef);
+
+       var
+          hp : preference;
+          hregister : tregister;
+          neglabel,poslabel : plabel;
+          is_register : boolean;
+
+      begin
+         { convert from p2 to p1 }
+         { range check from enums is not made yet !!}
+         { and its probably not easy }
+         if (p1^.deftype<>orddef) or (p2^.deftype<>orddef) then
+           exit;
+         { range checking is different for u32bit }
+         { lets try to generate it allways }
+         if (cs_rangechecking in aktswitches)  and
+           { with $R+ explicit type conversations in TP aren't range checked! }
+           (not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and
+           ((porddef(p1)^.von>porddef(p2)^.von) or
+           (porddef(p1)^.bis<porddef(p2)^.bis) or
+           (porddef(p1)^.typ=u32bit) or
+           (porddef(p2)^.typ=u32bit)) then
+           begin
+              porddef(p1)^.genrangecheck;
+              is_register:=(p^.left^.location.loc=LOC_REGISTER) or
+                (p^.left^.location.loc=LOC_CREGISTER);
+              if porddef(p2)^.typ=u8bit then
+                begin
+                   if is_register then
+                     exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,p^.left^.location.register,R_EDI)))
+                   else
+                     exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.left^.location.reference),R_EDI)));
+                   hregister:=R_EDI;
+                end
+              else if porddef(p2)^.typ=s8bit then
+                begin
+                   if is_register then
+                     exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_BL,p^.left^.location.register,R_EDI)))
+                   else
+                     exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_BL,newreference(p^.left^.location.reference),R_EDI)));
+                   hregister:=R_EDI;
+                end
+              { rangechecking for u32bit ?? !!!!!!}
+              { lets try }
+              else if (porddef(p2)^.typ=s32bit) or (porddef(p2)^.typ=u32bit)  then
+                begin
+                   if is_register then
+                     hregister:=p^.location.register
+                   else
+                     begin
+                        exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),R_EDI)));
+                        hregister:=R_EDI;
+                     end;
+                end
+              else if porddef(p2)^.typ=u16bit then
+                begin
+                   if is_register then
+                     exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,p^.left^.location.register,R_EDI)))
+                   else
+                     exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.left^.location.reference),R_EDI)));
+                   hregister:=R_EDI;
+                end
+              else if porddef(p2)^.typ=s16bit then
+                begin
+                   if is_register then
+                     exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_WL,p^.left^.location.register,R_EDI)))
+                   else
+                     exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,newreference(p^.left^.location.reference),R_EDI)));
+                   hregister:=R_EDI;
+                end
+              else internalerror(6);
+              new(hp);
+              reset_reference(hp^);
+              hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr));
+              if porddef(p1)^.von>porddef(p1)^.bis then
+                begin
+                   getlabel(neglabel);
+                   getlabel(poslabel);
+                   exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L,hregister,hregister)));
+                   emitl(A_JL,neglabel);
+                end;
+              exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hp)));
+              if porddef(p1)^.von>porddef(p1)^.bis then
+                begin
+                   new(hp);
+                   reset_reference(hp^);
+                   hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr+1));
+                   emitl(A_JMP,poslabel);
+                   emitl(A_LABEL,neglabel);
+                   exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hp)));
+                   emitl(A_LABEL,poslabel);
+                end;
+
+           end;
+      end;
+
+     type
+        tsecondconvproc = procedure(p,hp : ptree;convtyp : tconverttype);
+
+    procedure second_nothing(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+      end;
+
+    procedure second_only_rangecheck(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         maybe_rangechecking(p,hp^.resulttype,p^.resulttype);
+      end;
+
+    procedure second_bigger(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         hregister : tregister;
+         opsize : topsize;
+         op : tasmop;
+         is_register : boolean;
+
+      begin
+           is_register:=p^.left^.location.loc=LOC_REGISTER;
+           if not(is_register) and (p^.left^.location.loc<>LOC_CREGISTER) then
+             begin
+                del_reference(p^.left^.location.reference);
+                { we can do this here as we need no temp inside second_bigger }
+                ungetiftemp(p^.left^.location.reference);
+             end;
+         { this is wrong !!!
+         gives me movl (%eax),%eax
+         for the length(string !!!
+         use only for constant values }
+           {Constanst cannot be loaded into registers using MOVZX!}
+           if (p^.left^.location.loc<>LOC_MEM) or (not p^.left^.location.reference.isintvalue) then
+                case convtyp of
+                    tc_u8bit_2_s32bit,tc_u8bit_2_u32bit :
+                      begin
+                          if is_register then
+                            hregister:=reg8toreg32(p^.left^.location.register)
+                          else hregister:=getregister32;
+                          op:=A_MOVZX;
+                          opsize:=S_BL;
+                      end;
+                    { here what do we do for negative values ? }
+                    tc_s8bit_2_s32bit,tc_s8bit_2_u32bit :
+                      begin
+                          if is_register then
+                            hregister:=reg8toreg32(p^.left^.location.register)
+                          else hregister:=getregister32;
+                          op:=A_MOVSX;
+                          opsize:=S_BL;
+                      end;
+                    tc_u16bit_2_s32bit,tc_u16bit_2_u32bit :
+                      begin
+                          if is_register then
+                            hregister:=reg16toreg32(p^.left^.location.register)
+                          else hregister:=getregister32;
+                          op:=A_MOVZX;
+                          opsize:=S_WL;
+                      end;
+                    tc_s16bit_2_s32bit,tc_s16bit_2_u32bit :
+                      begin
+                          if is_register then
+                            hregister:=reg16toreg32(p^.left^.location.register)
+                          else hregister:=getregister32;
+                          op:=A_MOVSX;
+                          opsize:=S_WL;
+                      end;
+                    tc_s8bit_2_u16bit,
+                    tc_u8bit_2_s16bit,
+                    tc_u8bit_2_u16bit :
+                      begin
+                          if is_register then
+                            hregister:=reg8toreg16(p^.left^.location.register)
+                          else hregister:=reg32toreg16(getregister32);
+                          op:=A_MOVZX;
+                          opsize:=S_BW;
+                      end;
+                    tc_s8bit_2_s16bit :
+                      begin
+                          if is_register then
+                            hregister:=reg8toreg16(p^.left^.location.register)
+                          else hregister:=reg32toreg16(getregister32);
+                          op:=A_MOVSX;
+                          opsize:=S_BW;
+                      end;
+                end
+           else
+                case convtyp of
+                    tc_u8bit_2_s32bit,
+                    tc_s8bit_2_s32bit,
+                    tc_u16bit_2_s32bit,
+                    tc_s16bit_2_s32bit,
+                    tc_u8bit_2_u32bit,
+                    tc_s8bit_2_u32bit,
+                    tc_u16bit_2_u32bit,
+                    tc_s16bit_2_u32bit:
+                      begin
+                         hregister:=getregister32;
+                         op:=A_MOV;
+                         opsize:=S_L;
+                      end;
+                    tc_s8bit_2_u16bit,
+                    tc_s8bit_2_s16bit,
+                    tc_u8bit_2_s16bit,
+                    tc_u8bit_2_u16bit:
+                      begin
+                         hregister:=reg32toreg16(getregister32);
+                         op:=A_MOV;
+                         opsize:=S_W;
+                     end;
+                end;
+           if is_register then
+             begin
+                 emit_reg_reg(op,opsize,p^.left^.location.register,hregister);
+             end
+           else
+             begin
+                 if p^.left^.location.loc=LOC_CREGISTER then
+                    emit_reg_reg(op,opsize,p^.left^.location.register,hregister)
+                 else exprasmlist^.concat(new(pai386,op_ref_reg(op,opsize,
+                    newreference(p^.left^.location.reference),hregister)));
+             end;
+           p^.location.loc:=LOC_REGISTER;
+           p^.location.register:=hregister;
+           maybe_rangechecking(p,p^.left^.resulttype,p^.resulttype);
+       end;
+
+    procedure second_string_string(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         pushedregs : tpushed;
+
+      begin
+         stringdispose(p^.location.reference.symbol);
+         gettempofsizereference(p^.resulttype^.size,p^.location.reference);
+         del_reference(p^.left^.location.reference);
+         copystring(p^.location.reference,p^.left^.location.reference,pstringdef(p^.resulttype)^.len);
+         ungetiftemp(p^.left^.location.reference);
+      end;
+
+    procedure second_cstring_charpointer(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=getregister32;
+         inc(p^.left^.location.reference.offset);
+           exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
+             p^.location.register)));
+      end;
+
+    procedure second_string_chararray(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         inc(p^.location.reference.offset);
+      end;
+
+    procedure second_array_to_pointer(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         del_reference(p^.left^.location.reference);
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=getregister32;
+         exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference),
+           p^.location.register)));
+      end;
+
+    procedure second_pointer_to_array(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         p^.location.loc:=LOC_REFERENCE;
+         clear_reference(p^.location.reference);
+         if p^.left^.location.loc=LOC_REGISTER then
+           p^.location.reference.base:=p^.left^.location.register
+         else
+           begin
+              if p^.left^.location.loc=LOC_CREGISTER then
+                begin
+                   p^.location.reference.base:=getregister32;
+                   emit_reg_reg(A_MOV,S_L,p^.left^.location.register,
+                     p^.location.reference.base);
+                end
+              else
+                begin
+                   del_reference(p^.left^.location.reference);
+                   p^.location.reference.base:=getregister32;
+                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
+                     p^.location.reference.base)));
+                end;
+           end;
+      end;
+
+    { generates the code for the type conversion from an array of char }
+    { to a string                                                        }
+    procedure second_chararray_to_string(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         l : longint;
+
+      begin
+         { this is a type conversion which copies the data, so we can't }
+         { return a reference                                             }
+         p^.location.loc:=LOC_MEM;
+
+         { first get the memory for the string }
+         stringdispose(p^.location.reference.symbol);
+         gettempofsizereference(256,p^.location.reference);
+
+         { calc the length of the array }
+         l:=parraydef(p^.left^.resulttype)^.highrange-
+           parraydef(p^.left^.resulttype)^.lowrange+1;
+
+         if l>255 then
+           Message(sym_e_type_mismatch);
+
+         { write the length }
+             exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,l,
+               newreference(p^.location.reference))));
+
+         { copy to first char of string }
+         inc(p^.location.reference.offset);
+
+         { generates the copy code      }
+         { and we need the source never }
+         concatcopy(p^.left^.location.reference,p^.location.reference,l,true);
+
+         { correct the string location }
+         dec(p^.location.reference.offset);
+      end;
+
+    procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         stringdispose(p^.location.reference.symbol);
+         gettempofsizereference(256,p^.location.reference);
+      { call loadstring with correct left and right }
+         p^.right:=p^.left;
+         p^.left:=p;
+         loadstring(p);
+         p^.left:=nil; { reset left tree, which is empty }
+      end;
+
+    procedure second_int_real(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         r : preference;
+
+      begin
+         if (p^.left^.location.loc=LOC_REGISTER) or
+            (p^.left^.location.loc=LOC_CREGISTER) then
+           begin
+              case porddef(p^.left^.resulttype)^.typ of
+                 s8bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_BL,p^.left^.location.register,R_EDI)));
+                 u8bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,p^.left^.location.register,R_EDI)));
+                 s16bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_WL,p^.left^.location.register,R_EDI)));
+                 u16bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,p^.left^.location.register,R_EDI)));
+                 u32bit,s32bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,p^.left^.location.register,R_EDI)));
+                 {!!!! u32bit }
+              end;
+              ungetregister(p^.left^.location.register);
+           end
+         else
+           begin
+              r:=newreference(p^.left^.location.reference);
+              case porddef(p^.left^.resulttype)^.typ of
+                 s8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_BL,r,R_EDI)));
+                 u8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,r,R_EDI)));
+                 s16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,r,R_EDI)));
+                 u16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,r,R_EDI)));
+                 u32bit,s32bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI)));
+                 {!!!! u32bit }
+              end;
+              del_reference(p^.left^.location.reference);
+              ungetiftemp(p^.left^.location.reference);
+         end;
+          if porddef(p^.left^.resulttype)^.typ=u32bit then
+            push_int(0);
+          exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EDI)));
+         new(r);
+         reset_reference(r^);
+         r^.base:=R_ESP;
+         { for u32bit a solution would be to push $0 and to load a
+         comp }
+          if porddef(p^.left^.resulttype)^.typ=u32bit then
+            exprasmlist^.concat(new(pai386,op_ref(A_FILD,S_Q,r)))
+          else
+            exprasmlist^.concat(new(pai386,op_ref(A_FILD,S_L,r)));
+
+         { better than an add on all processors }
+         if porddef(p^.left^.resulttype)^.typ=u32bit then
+           exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,8,R_ESP)))
+         else
+           exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI)));
+
+         p^.location.loc:=LOC_FPU;
+      end;
+
+    procedure second_real_fix(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         {hs : string;}
+         rreg : tregister;
+         ref : treference;
+
+      begin
+         { real must be on fpu stack }
+         if (p^.left^.location.loc<>LOC_FPU) then
+           exprasmlist^.concat(new(pai386,op_ref(A_FLD,S_L,newreference(p^.left^.location.reference))));
+         push_int($1f3f);
+         push_int(65536);
+         reset_reference(ref);
+         ref.base:=R_ESP;
+
+         exprasmlist^.concat(new(pai386,op_ref(A_FIMUL,S_L,newreference(ref))));
+
+         ref.offset:=4;
+         exprasmlist^.concat(new(pai386,op_ref(A_FSTCW,S_L,newreference(ref))));
+
+         ref.offset:=6;
+         exprasmlist^.concat(new(pai386,op_ref(A_FLDCW,S_L,newreference(ref))));
+
+         ref.offset:=0;
+         exprasmlist^.concat(new(pai386,op_ref(A_FISTP,S_L,newreference(ref))));
+
+         ref.offset:=4;
+         exprasmlist^.concat(new(pai386,op_ref(A_FLDCW,S_L,newreference(ref))));
+
+         rreg:=getregister32;
+         exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,rreg)));
+         { better than an add on all processors }
+         exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI)));
+
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=rreg;
+      end;
+
+    procedure second_float_float(p,hp : ptree;convtyp : tconverttype);
+
+      begin
+         case p^.left^.location.loc of
+            LOC_FPU : ;
+            LOC_MEM,
+            LOC_REFERENCE:
+              begin
+                 floatload(pfloatdef(p^.left^.resulttype)^.typ,
+                   p^.left^.location.reference);
+                 { we have to free the reference }
+                 del_reference(p^.left^.location.reference);
+              end;
+         end;
+         p^.location.loc:=LOC_FPU;
+      end;
+
+    procedure second_fix_real(p,hp : ptree;convtyp : tconverttype);
+
+    var popeax,popebx,popecx,popedx : boolean;
+        startreg : tregister;
+        hl : plabel;
+        r : treference;
+
+      begin
+         if (p^.left^.location.loc=LOC_REGISTER) or
+            (p^.left^.location.loc=LOC_CREGISTER) then
+           begin
+              startreg:=p^.left^.location.register;
+              ungetregister(startreg);
+              popeax:=(startreg<>R_EAX) and not (R_EAX in unused);
+              if popeax then
+                exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EAX)));
+              { mov eax,eax is removed by emit_reg_reg }
+              emit_reg_reg(A_MOV,S_L,startreg,R_EAX);
+           end
+         else
+           begin
+              exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(
+                p^.left^.location.reference),R_EAX)));
+              del_reference(p^.left^.location.reference);
+              startreg:=R_NO;
+           end;
+
+         popebx:=(startreg<>R_EBX) and not (R_EBX in unused);
+         if popebx then
+           exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EBX)));
+
+         popecx:=(startreg<>R_ECX) and not (R_ECX in unused);
+         if popecx then
+           exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ECX)));
+
+         popedx:=(startreg<>R_EDX) and not (R_EDX in unused);
+         if popedx then
+           exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EDX)));
+
+         exprasmlist^.concat(new(pai386,op_none(A_CDQ,S_NO)));
+         emit_reg_reg(A_XOR,S_L,R_EDX,R_EAX);
+         emit_reg_reg(A_MOV,S_L,R_EAX,R_EBX);
+         emit_reg_reg(A_SUB,S_L,R_EDX,R_EAX);
+         getlabel(hl);
+         emitl(A_JZ,hl);
+         exprasmlist^.concat(new(pai386,op_const_reg(A_RCL,S_L,1,R_EBX)));
+         emit_reg_reg(A_BSR,S_L,R_EAX,R_EDX);
+         exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B,32,R_CL)));
+         emit_reg_reg(A_SUB,S_B,R_DL,R_CL);
+         emit_reg_reg(A_SHL,S_L,R_CL,R_EAX);
+         exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_W,1007,R_DX)));
+         exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_W,5,R_DX)));
+         exprasmlist^.concat(new(pai386,op_const_reg_reg(A_SHLD,S_W,11,R_DX,R_BX)));
+         exprasmlist^.concat(new(pai386,op_const_reg_reg(A_SHLD,S_W,20,R_EAX,R_EBX)));
+
+         exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,20,R_EAX)));
+         emitl(A_LABEL,hl);
+         { better than an add on all processors }
+         exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EBX)));
+         exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EAX)));
+
+         reset_reference(r);
+         r.base:=R_ESP;
+         exprasmlist^.concat(new(pai386,op_ref(A_FLD,S_L,newreference(r))));
+         exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,8,R_ESP)));
+         if popedx then
+           exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDX)));
+         if popecx then
+           exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_ECX)));
+         if popebx then
+           exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EBX)));
+         if popeax then
+           exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EAX)));
+
+         p^.location.loc:=LOC_FPU;
+      end;
+
+    procedure second_int_fix(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         {hs : string;}
+         hregister : tregister;
+
+      begin
+         if (p^.left^.location.loc=LOC_REGISTER) then
+           hregister:=p^.left^.location.register
+         else if (p^.left^.location.loc=LOC_CREGISTER) then
+           hregister:=getregister32
+         else
+           begin
+              del_reference(p^.left^.location.reference);
+              hregister:=getregister32;
+              case porddef(p^.left^.resulttype)^.typ of
+                s8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_BL,newreference(p^.left^.location.reference),
+                  hregister)));
+                u8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.left^.location.reference),
+                  hregister)));
+                s16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,newreference(p^.left^.location.reference),
+                  hregister)));
+                u16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.left^.location.reference),
+                  hregister)));
+                u32bit,s32bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
+                  hregister)));
+                {!!!! u32bit }
+              end;
+           end;
+         exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,16,hregister)));
+
+         p^.location.loc:=LOC_REGISTER;
+         p^.location.register:=hregister;
+      end;
+
+    procedure second_smaller(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         hregister,destregister : tregister;
+         ref : boolean;
+         hpp : preference;
+
+      begin
+         ref:=false;
+         { problems with enums !! }
+         if (cs_rangechecking in aktswitches)  and
+           { with $R+ explicit type conversations in TP aren't range checked! }
+           (not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and
+           (p^.resulttype^.deftype=orddef) and
+           (hp^.resulttype^.deftype=orddef) and
+           ((porddef(p^.resulttype)^.von>porddef(hp^.resulttype)^.von) or
+           (porddef(p^.resulttype)^.bis<porddef(hp^.resulttype)^.bis)) then
+           begin
+              porddef(p^.resulttype)^.genrangecheck;
+              { per default the var is copied to EDI }
+              hregister:=R_EDI;
+              if porddef(hp^.resulttype)^.typ=s32bit then
+                begin
+                   if (p^.location.loc=LOC_REGISTER) or
+                      (p^.location.loc=LOC_CREGISTER) then
+                     hregister:=p^.location.register
+                   else
+                     exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),R_EDI)));
+                end
+              { range checking for u32bit ?? !!!!!!}
+              else if porddef(hp^.resulttype)^.typ=u16bit then
+                begin
+                   if (p^.location.loc=LOC_REGISTER) or
+                      (p^.location.loc=LOC_CREGISTER) then
+                     exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,p^.location.register,R_EDI)))
+                   else
+                     exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.location.reference),R_EDI)));
+                end
+              else if porddef(hp^.resulttype)^.typ=s16bit then
+                begin
+                   if (p^.location.loc=LOC_REGISTER) or
+                      (p^.location.loc=LOC_CREGISTER) then
+                     exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_WL,p^.location.register,R_EDI)))
+                   else
+                     exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,newreference(p^.location.reference),R_EDI)));
+                end
+              else internalerror(6);
+              new(hpp);
+              reset_reference(hpp^);
+              hpp^.symbol:=stringdup('R_'+tostr(porddef(p^.resulttype)^.rangenr));
+              exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hpp)));
+              (*
+              if (p^.location.loc=LOC_REGISTER) or
+                 (p^.location.loc=LOC_CREGISTER) then
+                begin
+                   destregister:=p^.left^.location.register;
+                   case convtyp of
+                      tc_s32bit_2_s8bit,
+                      tc_s32bit_2_u8bit:
+                        destregister:=reg32toreg8(destregister);
+                      tc_s32bit_2_s16bit,
+                      tc_s32bit_2_u16bit:
+                        destregister:=reg32toreg16(destregister);
+                      { this was false because destregister is allways a 32bitreg }
+                      tc_s16bit_2_s8bit,
+                      tc_s16bit_2_u8bit,
+                      tc_u16bit_2_s8bit,
+                      tc_u16bit_2_u8bit:
+                        destregister:=reg32toreg8(destregister);
+                   end;
+              p^.location.register:=destregister;
+              exit;
+              *)
+           end;
+         { p^.location.loc is already set! }
+         if (p^.location.loc=LOC_REGISTER) or
+           (p^.location.loc=LOC_CREGISTER) then
+           begin
+              destregister:=p^.left^.location.register;
+              case convtyp of
+                 tc_s32bit_2_s8bit,
+                 tc_s32bit_2_u8bit:
+                   destregister:=reg32toreg8(destregister);
+                 tc_s32bit_2_s16bit,
+                 tc_s32bit_2_u16bit:
+                   destregister:=reg32toreg16(destregister);
+                 tc_s16bit_2_s8bit,
+                 tc_s16bit_2_u8bit,
+                 tc_u16bit_2_s8bit,
+                 tc_u16bit_2_u8bit:
+                   destregister:=reg16toreg8(destregister);
+              end;
+              p^.location.register:=destregister;
+           end;
+      end;
+
+     procedure second_proc_to_procvar(p,hp : ptree;convtyp : tconverttype);
+
+     begin
+          secondpass(hp);
+          p^.location.loc:=LOC_REGISTER;
+          del_reference(hp^.location.reference);
+          p^.location.register:=getregister32;
+          exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
+           newreference(hp^.location.reference),p^.location.register)));
+     end;
+
+     procedure second_bool_to_byte(p,hp : ptree;convtyp : tconverttype);
+
+      var
+         oldtruelabel,oldfalselabel,hlabel : plabel;
+
+     begin
+         oldtruelabel:=truelabel;
+         oldfalselabel:=falselabel;
+         getlabel(truelabel);
+         getlabel(falselabel);
+          secondpass(hp);
+          p^.location.loc:=LOC_REGISTER;
+          del_reference(hp^.location.reference);
+          p^.location.register:=reg32toreg8(getregister32);
+          case hp^.location.loc of
+            LOC_MEM,LOC_REFERENCE :
+              exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_B,
+                newreference(hp^.location.reference),p^.location.register)));
+            LOC_REGISTER,LOC_CREGISTER :
+              exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_B,
+                hp^.location.register,p^.location.register)));
+           LOC_FLAGS:
+              begin
+                 exprasmlist^.concat(new(pai386,op_reg(flag_2_set[hp^.location.resflags],S_NO,
+                   p^.location.register)))
+              end;
+           LOC_JUMP:
+             begin
+                getlabel(hlabel);
+                emitl(A_LABEL,truelabel);
+                exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B,
+                  1,p^.location.register)));
+                emitl(A_JMP,hlabel);
+                emitl(A_LABEL,falselabel);
+                exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B,
+                  p^.location.register,
+                  p^.location.register)));
+                emitl(A_LABEL,hlabel);
+             end;
+          else
+            internalerror(10060);
+          end;
+         truelabel:=oldtruelabel;
+         falselabel:=oldfalselabel;
+     end;
+
+    procedure secondtypeconv(var p : ptree);
+
+      const
+         secondconvert : array[tc_u8bit_2_s32bit..tc_cchar_charpointer] of
+           tsecondconvproc = (second_bigger,second_only_rangecheck,
+           second_bigger,second_bigger,second_bigger,
+           second_smaller,second_smaller,
+           second_smaller,second_string_string,
+           second_cstring_charpointer,second_string_chararray,
+           second_array_to_pointer,second_pointer_to_array,
+           second_char_to_string,second_bigger,
+           second_bigger,second_bigger,
+           second_smaller,second_smaller,
+           second_smaller,second_smaller,
+           second_bigger,second_smaller,
+           second_only_rangecheck,second_bigger,
+           second_bigger,second_bigger,
+           second_bigger,second_only_rangecheck,
+           second_int_real,second_real_fix,
+           second_fix_real,second_int_fix,second_float_float,
+               second_chararray_to_string,second_bool_to_byte,
+               second_proc_to_procvar,
+               { is constant char to pchar, is done by firstpass }
+               second_nothing);
+
+      begin
+         { this isn't good coding, I think tc_bool_2_u8bit, shouldn't be }
+         { type conversion (FK)                                        }
+
+         { this is necessary, because second_bool_byte, have to change   }
+         { true- and false label before calling secondpass               }
+         if p^.convtyp<>tc_bool_2_u8bit then
+           begin
+              secondpass(p^.left);
+              set_location(p^.location,p^.left^.location);
+           end;
+         if p^.convtyp<>tc_equal then
+           {the second argument only is for maybe_range_checking !}
+           secondconvert[p^.convtyp](p,p^.left,p^.convtyp)
+      end;
+
+
+    procedure secondassignment(var p : ptree);
+
+      var
+         opsize : topsize;
+         {pushed,}withresult : boolean;
+         otlabel,hlabel,oflabel : plabel;
+         hregister : tregister;
+         loc : tloc;
+
+      begin
+         otlabel:=truelabel;
+         oflabel:=falselabel;
+         getlabel(truelabel);
+         getlabel(falselabel);
+         withresult:=not(aktexprlevel<4);
+         { calculate left sides }
+         secondpass(p^.left);
+         case p^.left^.location.loc of
+            LOC_REFERENCE : begin
+                              { in case left operator uses to register }
+                              { but to few are free then LEA }
+                              if (p^.left^.location.reference.base<>R_NO) and
+                                 (p^.left^.location.reference.index<>R_NO) and
+                                 (usablereg32<p^.right^.registers32) then
+                                begin
+                                   del_reference(p^.left^.location.reference);
+                                   hregister:=getregister32;
+                                   exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(
+                                     p^.left^.location.reference),
+                                     hregister)));
+                                   clear_reference(p^.left^.location.reference);
+                                   p^.left^.location.reference.base:=hregister;
+                                   p^.left^.location.reference.index:=R_NO;
+                                end;
+                              loc:=LOC_REFERENCE;
+                           end;
+            LOC_CREGISTER:
+              loc:=LOC_CREGISTER;
+            LOC_MMXREGISTER:
+              loc:=LOC_MMXREGISTER;
+            LOC_CMMXREGISTER:
+              loc:=LOC_CMMXREGISTER;
+            else
+               begin
+                  Message(cg_e_illegal_expression);
+                  exit;
+               end;
+         end;
+         { lets try to optimize this (PM)             }
+         { define a dest_loc that is the location      }
+         { and a ptree to verify that it is the right }
+         { place to insert it                         }
+{$ifdef test_dest_loc}
+         if (aktexprlevel<4) then
+           begin
+              dest_loc_known:=true;
+              dest_loc:=p^.left^.location;
+              dest_loc_tree:=p^.right;
+           end;
+{$endif test_dest_loc}
+
+         if (p^.right^.treetype=realconstn) then
+           begin
+              if p^.left^.resulttype^.deftype=floatdef then
+                begin
+                   case pfloatdef(p^.left^.resulttype)^.typ of
+                     s32real : p^.right^.realtyp:=ait_real_32bit;
+                     s64real : p^.right^.realtyp:=ait_real_64bit;
+                     s80real : p^.right^.realtyp:=ait_real_extended;
+                     { what about f32bit and s64bit }
+                     end;
+                end;
+           end;
+         secondpass(p^.right);
+{$ifdef test_dest_loc}
+         dest_loc_known:=false;
+         if in_dest_loc then
+           begin
+              truelabel:=otlabel;
+              falselabel:=oflabel;
+              in_dest_loc:=false;
+              exit;
+           end;
+{$endif test_dest_loc}
+         if p^.left^.resulttype^.deftype=stringdef then
+           begin
+             { we do not need destination anymore }
+             del_reference(p^.left^.location.reference);
+             { only source if withresult is set }
+             if not(withresult) then
+               del_reference(p^.right^.location.reference);
+             loadstring(p);
+             ungetiftemp(p^.right^.location.reference);
+           end
+        else case p^.right^.location.loc of
+            LOC_REFERENCE,
+            LOC_MEM : begin
+                         { handle ordinal constants trimmed }
+                         if (p^.right^.treetype in [ordconstn,fixconstn]) or
+                            (loc=LOC_CREGISTER) then
+                           begin
+                              case p^.left^.resulttype^.size of
+                                 1 : opsize:=S_B;
+                                 2 : opsize:=S_W;
+                                 4 : opsize:=S_L;
+                              end;
+                              if loc=LOC_CREGISTER then
+                                exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
+                                  newreference(p^.right^.location.reference),
+                                  p^.left^.location.register)))
+                              else
+                                exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,opsize,
+                                  p^.right^.location.reference.offset,
+                                  newreference(p^.left^.location.reference))));
+                              {exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,opsize,
+                                  p^.right^.location.reference.offset,
+                                  p^.left^.location)));}
+                           end
+                         else
+                           begin
+                              concatcopy(p^.right^.location.reference,
+                                p^.left^.location.reference,p^.left^.resulttype^.size,
+                                withresult);
+                              ungetiftemp(p^.right^.location.reference);
+                           end;
+                      end;
+{$ifdef SUPPORT_MMX}
+            LOC_CMMXREGISTER,
+            LOC_MMXREGISTER:
+              begin
+                 if loc=LOC_CMMXREGISTER then
+                   exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVQ,S_NO,
+                   p^.right^.location.register,p^.left^.location.register)))
+                 else
+                   exprasmlist^.concat(new(pai386,op_reg_ref(A_MOVQ,S_NO,
+                     p^.right^.location.register,newreference(p^.left^.location.reference))));
+              end;
+{$endif SUPPORT_MMX}
+            LOC_REGISTER,
+            LOC_CREGISTER : begin
+                              case p^.right^.resulttype^.size of
+                                 1 : opsize:=S_B;
+                                 2 : opsize:=S_W;
+                                 4 : opsize:=S_L;
+                              end;
+                              { simplified with op_reg_loc         }
+                              if loc=LOC_CREGISTER then
+                                exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,opsize,
+                                  p^.right^.location.register,
+                                  p^.left^.location.register)))
+                              else
+                                exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,
+                                  p^.right^.location.register,
+                                  newreference(p^.left^.location.reference))));
+                              {exprasmlist^.concat(new(pai386,op_reg_loc(A_MOV,opsize,
+                                  p^.right^.location.register,
+                                  p^.left^.location)));             }
+
+                           end;
+            LOC_FPU : begin
+                              if loc<>LOC_REFERENCE then
+                                internalerror(10010)
+                              else
+                                floatstore(pfloatdef(p^.left^.resulttype)^.typ,
+                                  p^.left^.location.reference);
+                           end;
+            LOC_JUMP     : begin
+                              getlabel(hlabel);
+                              emitl(A_LABEL,truelabel);
+                              if loc=LOC_CREGISTER then
+                                exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B,
+                                  1,p^.left^.location.register)))
+                              else
+                                exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
+                                  1,newreference(p^.left^.location.reference))));
+                              {exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,S_B,
+                                  1,p^.left^.location)));}
+                              emitl(A_JMP,hlabel);
+                              emitl(A_LABEL,falselabel);
+                              if loc=LOC_CREGISTER then
+                                exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B,
+                                  p^.left^.location.register,
+                                  p^.left^.location.register)))
+                              else
+                                exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
+                                  0,newreference(p^.left^.location.reference))));
+                              emitl(A_LABEL,hlabel);
+                           end;
+            LOC_FLAGS    : begin
+                              if loc=LOC_CREGISTER then
+                                exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_NO,
+                                  p^.left^.location.register)))
+                              else
+                                exprasmlist^.concat(new(pai386,op_ref(flag_2_set[p^.right^.location.resflags],S_NO,
+                                  newreference(p^.left^.location.reference))));
+                           end;
+         end;
+         truelabel:=otlabel;
+         falselabel:=oflabel;
+      end;
+
+
+
+    { save the size of pushed parameter }
+    var
+       pushedparasize : longint;
+
+    procedure secondcallparan(var p : ptree;defcoll : pdefcoll;
+                push_from_left_to_right : boolean);
+
+      var
+         size : longint;
+         stackref : treference;
+         otlabel,hlabel,oflabel : plabel;
+
+
+         { temporary variables: }
+         tempdeftype : tdeftype;
+         tempreference : treference;
+         r : preference;
+         s : topsize;
+         op : tasmop;
+
+      begin
+         { push from left to right if specified }
+         if push_from_left_to_right and assigned(p^.right) then
+           secondcallparan(p^.right,defcoll^.next,push_from_left_to_right);
+         otlabel:=truelabel;
+         oflabel:=falselabel;
+         getlabel(truelabel);
+         getlabel(falselabel);
+         secondpass(p^.left);
+         { in codegen.handleread.. defcoll^.data is set to nil }
+         if assigned(defcoll^.data) and
+           (defcoll^.data^.deftype=formaldef) then
+           begin
+              { allow @var }
+              if p^.left^.treetype=addrn then
+                begin
+                   { allways a register }
+                   exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register)));
+                   ungetregister32(p^.left^.location.register);
+                end
+              else
+                begin
+                   if (p^.left^.location.loc<>LOC_REFERENCE) and
+                      (p^.left^.location.loc<>LOC_MEM) then
+                     Message(sym_e_type_mismatch)
+                   else
+                     begin
+                        emitpushreferenceaddr(p^.left^.location.reference);
+                        del_reference(p^.left^.location.reference);
+                     end;
+                end;
+              inc(pushedparasize,4);
+           end
+         { handle call by reference parameter }
+         else if (defcoll^.paratyp=vs_var) then
+           begin
+              if (p^.left^.location.loc<>LOC_REFERENCE) then
+                Message(cg_e_var_must_be_reference);
+              { open array ? }
+              { defcoll^.data can be nil for read/write }
+              if assigned(defcoll^.data) and
+                is_open_array(defcoll^.data) then
+                begin
+                   { push high }
+                   if is_open_array(p^.left^.resulttype) then
+                     begin
+                        new(r);
+                        reset_reference(r^);
+                        r^.base:=highframepointer;
+                        r^.offset:=highoffset+4;
+                        exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,r)));
+                     end
+                   else
+                     push_int(parraydef(p^.left^.resulttype)^.highrange-
+                              parraydef(p^.left^.resulttype)^.lowrange);
+                   inc(pushedparasize,4);
+                end;
+              emitpushreferenceaddr(p^.left^.location.reference);
+              del_reference(p^.left^.location.reference);
+              inc(pushedparasize,4);
+           end
+         else
+           begin
+              tempdeftype:=p^.resulttype^.deftype;
+              if tempdeftype=filedef then
+               Message(cg_e_file_must_call_by_reference);
+              if (defcoll^.paratyp=vs_const) and
+                 dont_copy_const_param(p^.resulttype) then
+                begin
+                   emitpushreferenceaddr(p^.left^.location.reference);
+                   del_reference(p^.left^.location.reference);
+                   inc(pushedparasize,4);
+                end
+              else
+                case p^.left^.location.loc of
+                   LOC_REGISTER,
+                   LOC_CREGISTER : begin
+                                     case p^.left^.location.register of
+                                        R_EAX,R_EBX,R_ECX,R_EDX,R_ESI,
+                                        R_EDI,R_ESP,R_EBP :
+                                          begin
+                                             exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register)));
+                                             inc(pushedparasize,4);
+                                             ungetregister32(p^.left^.location.register);
+                                          end;
+                                        R_AX,R_BX,R_CX,R_DX,R_SI,R_DI:
+                                          begin
+                                              exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,p^.left^.location.register)));
+                                              inc(pushedparasize,2);
+                                              ungetregister32(reg16toreg32(p^.left^.location.register));
+                                           end;
+                                        R_AL,R_BL,R_CL,R_DL:
+                                          begin
+                                             { we must push always 16 bit }
+                                             exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,
+                                               reg8toreg16(p^.left^.location.register))));
+                                             inc(pushedparasize,2);
+                                             ungetregister32(reg8toreg32(p^.left^.location.register));
+                                          end;
+                                     end;
+                                  end;
+                       LOC_FPU : begin
+                                        size:=pfloatdef(p^.left^.resulttype)^.size;
+                                        inc(pushedparasize,size);
+                                        exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,S_L,size,R_ESP)));
+                                        new(r);
+                                        reset_reference(r^);
+                                        r^.base:=R_ESP;
+                                        floatstoreops(pfloatdef(p^.left^.resulttype)^.typ,op,s);
+                                        exprasmlist^.concat(new(pai386,op_ref(op,s,r)));
+                                     end;
+                   LOC_REFERENCE,LOC_MEM :
+                                      begin
+                                          tempreference:=p^.left^.location.reference;
+                                  del_reference(p^.left^.location.reference);
+                                  case p^.resulttype^.deftype of
+                                     orddef : begin
+                                                   case porddef(p^.resulttype)^.typ of
+                                                      s32bit,u32bit :
+                                                        begin
+                                                           emit_push_mem(tempreference);
+                                                           inc(pushedparasize,4);
+                                                        end;
+                                                      s8bit,u8bit,uchar,bool8bit,s16bit,u16bit : begin
+                                                          exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_W,
+                                                            newreference(tempreference))));
+                                                          inc(pushedparasize,2);
+                                                      end;
+                                                    end;
+                                              end;
+                                     floatdef : begin
+                                                   case pfloatdef(p^.resulttype)^.typ of
+                                                      f32bit,
+                                                      s32real :
+                                                        begin
+                                                           emit_push_mem(tempreference);
+                                                           inc(pushedparasize,4);
+                                                        end;
+                                                      s64real,
+                                                      s64bit : begin
+                                                                   inc(tempreference.offset,4);
+                                                                   emit_push_mem(tempreference);
+                                                                   dec(tempreference.offset,4);
+                                                                   emit_push_mem(tempreference);
+                                                                   inc(pushedparasize,8);
+                                                                end;
+                                                      s80real : begin
+                                                                   inc(tempreference.offset,6);
+                                                                   emit_push_mem(tempreference);
+                                                                   dec(tempreference.offset,4);
+                                                                   emit_push_mem(tempreference);
+                                                                   dec(tempreference.offset,2);
+                                                                   exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_W,
+                                                                     newreference(tempreference))));
+                                                                   inc(pushedparasize,extended_size);
+                                                                end;
+                                                   end;
+                                                end;
+                                     pointerdef,procvardef,
+                     enumdef,classrefdef:
+                       begin
+                                          emit_push_mem(tempreference);
+                                          inc(pushedparasize,4);
+                                       end;
+                                     arraydef,recorddef,stringdef,setdef,objectdef :
+                                                begin
+                                                   if ((p^.resulttype^.deftype=setdef) and
+                                                     (psetdef(p^.resulttype)^.settype=smallset)) then
+                                                     begin
+                                                        emit_push_mem(tempreference);
+                                                        inc(pushedparasize,4);
+                                                     end
+                                                   else
+                                                     begin
+                                                        size:=p^.resulttype^.size;
+
+                                                        { Alignment }
+                                                        {
+                                                        if (size>=4) and ((size and 3)<>0) then
+                                                          inc(size,4-(size and 3))
+                                                        else if (size>=2) and ((size and 1)<>0) then
+                                                          inc(size,2-(size and 1))
+                                                        else
+                                                        if size=1 then size:=2;
+                                                        }
+                                                        { create stack space }
+                                                        exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,S_L,size,R_ESP)));
+                                                        inc(pushedparasize,size);
+                                                        { create stack reference }
+                                                        stackref.symbol := nil;
+                                                        clear_reference(stackref);
+                                                        stackref.base:=R_ESP;
+                                                        { produce copy }
+                                                        if p^.resulttype^.deftype=stringdef then
+                                                          begin
+                                                             copystring(stackref,p^.left^.location.reference,
+                                                               pstringdef(p^.resulttype)^.len);
+                                                          end
+                                                        else
+                                                          begin
+                                                             concatcopy(p^.left^.location.reference,
+                                                             stackref,p^.resulttype^.size,true);
+                                                          end;
+                                                     end;
+                                                end;
+                                              else Message(cg_e_illegal_expression);
+                                  end;
+                               end;
+                   LOC_JUMP:
+                     begin
+                        getlabel(hlabel);
+                        inc(pushedparasize,2);
+                        emitl(A_LABEL,truelabel);
+                        exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,1)));
+                        emitl(A_JMP,hlabel);
+                        emitl(A_LABEL,falselabel);
+                        exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,0)));
+                        emitl(A_LABEL,hlabel);
+                     end;
+                   LOC_FLAGS:
+                     begin
+                        if not(R_EAX in unused) then
+                          exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EAX,R_EDI)));
+
+                        { clear full EAX is faster }
+                        { but dont you set the equal flag ? }
+                        {exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_EAX,R_EAX)));}
+                        exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.left^.location.resflags],S_NO,
+                          R_AL)));
+                        exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BW,R_AL,R_AX)));
+                        {exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_EAX,R_EAX)));}
+                        inc(pushedparasize,2);
+                        exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,R_AX)));
+                        { this is also false !!!
+                        if not(R_EAX in unused) then
+                          exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EAX,R_EDI)));}
+                        if not(R_EAX in unused) then
+                          exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EDI,R_EAX)));
+                     end;
+{$ifdef SUPPORT_MMX}
+                   LOC_MMXREGISTER,
+                   LOC_CMMXREGISTER:
+                     begin
+                        exprasmlist^.concat(new(pai386,op_const_reg(
+                          A_SUB,S_L,8,R_ESP)));
+                        new(r);
+                        reset_reference(r^);
+                        r^.base:=R_ESP;
+                        exprasmlist^.concat(new(pai386,op_reg_ref(
+                          A_MOVQ,S_NO,p^.left^.location.register,r)));
+                     end;
+{$endif SUPPORT_MMX}
+                end;
+           end;
+         truelabel:=otlabel;
+         falselabel:=oflabel;
+         { push from right to left }
+         if not push_from_left_to_right and assigned(p^.right) then
+           secondcallparan(p^.right,defcoll^.next,push_from_left_to_right);
+      end;
+
+    procedure secondcalln(var p : ptree);
+
+      var
+         unusedregisters : tregisterset;
+         pushed : tpushed;
+         funcretref : treference;
+         hregister : tregister;
+         oldpushedparasize : longint;
+         { true if ESI must be loaded again after the subroutine }
+         loadesi : boolean;
+         { true if a virtual method must be called directly }
+         no_virtual_call : boolean;
+         { true if we produce a con- or destrutor in a call }
+         is_con_or_destructor : boolean;
+         { true if a constructor is called again }
+         extended_new : boolean;
+         { adress returned from an I/O-error }
+         iolabel : plabel;
+         { lexlevel count }
+         i : longint;
+         { help reference pointer }
+         r : preference;
+         pp,params : ptree;
+
+         { instruction for alignement correction }
+         corr : pai386;
+         { we must pop this size also after !! }
+         must_pop : boolean;
+         pop_size : longint;
+
+      label
+         dont_call;
+
+      begin
+         extended_new:=false;
+         iolabel:=nil;
+         loadesi:=true;
+         no_virtual_call:=false;
+         unusedregisters:=unused;
+         if not assigned(p^.procdefinition) then
+          exit;
+         { only if no proc var }
+         if not(assigned(p^.right)) then
+           is_con_or_destructor:=((p^.procdefinition^.options and poconstructor)<>0)
+             or ((p^.procdefinition^.options and podestructor)<>0);
+         { proc variables destroy all registers }
+         if (p^.right=nil) and
+            { virtual methods too }
+            ((p^.procdefinition^.options and povirtualmethod)=0) then
+           begin
+              if ((p^.procdefinition^.options and poiocheck)<>0)
+                and (cs_iocheck in aktswitches) then
+                begin
+                   getlabel(iolabel);
+                   emitl(A_LABEL,iolabel);
+                end
+              else iolabel:=nil;
+
+              { save all used registers }
+              pushusedregisters(pushed,p^.procdefinition^.usedregisters);
+
+              { give used registers through }
+              usedinproc:=usedinproc or p^.procdefinition^.usedregisters;
+           end
+         else
+           begin
+              pushusedregisters(pushed,$ff);
+              usedinproc:=$ff;
+              { no IO check for methods and procedure variables }
+              iolabel:=nil;
+           end;
+
+         { generate the code for the parameter and push them }
+         oldpushedparasize:=pushedparasize;
+         pushedparasize:=0;
+         corr:=new(pai386,op_const_reg(A_SUB,S_L,0,R_ESP));
+         exprasmlist^.concat(corr);
+         if (p^.resulttype<>pdef(voiddef)) and
+            ret_in_param(p^.resulttype) then
+           begin
+              funcretref.symbol:=nil;
+{$ifdef test_dest_loc}
+              if dest_loc_known and (dest_loc_tree=p) and
+                 (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then
+                begin
+                   funcretref:=dest_loc.reference;
+                   if assigned(dest_loc.reference.symbol) then
+                     funcretref.symbol:=stringdup(dest_loc.reference.symbol^);
+                   in_dest_loc:=true;
+                end
+              else
+{$endif test_dest_loc}
+                gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref);
+           end;
+         if assigned(p^.left) then
+           begin
+              pushedparasize:=0;
+              { be found elsewhere }
+              if assigned(p^.right) then
+                secondcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1,
+                  (p^.procdefinition^.options and poleftright)<>0)
+              else
+                secondcallparan(p^.left,p^.procdefinition^.para1,
+                  (p^.procdefinition^.options and poleftright)<>0);
+           end;
+         params:=p^.left;
+         p^.left:=nil;
+         if ret_in_param(p^.resulttype) then
+           begin
+              emitpushreferenceaddr(funcretref);
+              inc(pushedparasize,4);
+           end;
+         { overloaded operator have no symtable }
+         if (p^.right=nil) then
+           begin
+              { push self }
+              if assigned(p^.symtable) and
+                (p^.symtable^.symtabletype=withsymtable) then
+                begin
+                   { dirty trick to avoid the secondcall below }
+                   p^.methodpointer:=genzeronode(callparan);
+                   p^.methodpointer^.location.loc:=LOC_REGISTER;
+                   p^.methodpointer^.location.register:=R_ESI;
+                   { make a reference }
+                   new(r);
+                   reset_reference(r^);
+                   r^.offset:=p^.symtable^.datasize;
+                   r^.base:=procinfo.framepointer;
+                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI)));
+                end;
+
+              { push self }
+              if assigned(p^.symtable) and
+                ((p^.symtable^.symtabletype=objectsymtable) or
+                (p^.symtable^.symtabletype=withsymtable)) then
+                begin
+                   if assigned(p^.methodpointer) then
+                     begin
+                        {
+                        if p^.methodpointer^.resulttype=classrefdef then
+                          begin
+                              two possibilities:
+                               1. constructor
+                               2. class method
+
+                          end
+                        else }
+                          begin
+                             case p^.methodpointer^.treetype of
+                               typen:
+                                 begin
+                                    { direct call to inherited method }
+                                    if (p^.procdefinition^.options and poabstractmethod)<>0 then
+                                      begin
+                                         error(cg_e_cant_call_abstract_method);
+                                         goto dont_call;
+                                      end;
+                                    { generate no virtual call }
+                                    no_virtual_call:=true;
+
+                                    if (p^.symtableprocentry^.properties and sp_static)<>0 then
+                                      begin
+                                         { well lets put the VMT address directly into ESI }
+                                         { it is kind of dirty but that is the simplest    }
+                                         { way to accept virtual static functions (PM)     }
+                                         loadesi:=true;
+                                         exprasmlist^.concat(new(pai386,op_csymbol_reg(A_MOV,S_L,
+                                           newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_ESI)));
+                                         concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
+                                         exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
+                                      end
+                                    else
+                                      { this is a member call, so ESI isn't modfied }
+                                      loadesi:=false;
+                                    if not(is_con_or_destructor and
+                                      pobjectdef(p^.methodpointer^.resulttype)^.isclass and
+                                        assigned(aktprocsym) and
+                                        ((aktprocsym^.definition^.options and
+                                        (poconstructor or podestructor))<>0)) then
+                                      exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
+                                    { if an inherited con- or destructor should be  }
+                                    { called in a con- or destructor then a warning }
+                                    { will be made                                  }
+                                    { con- and destructors need a pointer to the vmt }
+                                    if is_con_or_destructor and
+                                    not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) and
+                                    assigned(aktprocsym) then
+                                      begin
+                                         if not ((aktprocsym^.definition^.options
+                                           and (poconstructor or podestructor))<>0) then
+
+                                          Message(cg_w_member_cd_call_from_method);
+                                      end;
+                                    if is_con_or_destructor then
+                                      push_int(0)
+                                 end;
+                               hnewn:
+                                 begin
+                                    { extended syntax of new }
+                                    { ESI must be zero }
+                                    exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_ESI,R_ESI)));
+                                    exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
+                                    { insert the vmt }
+                                    exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L,
+                                    newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0))));
+                                    concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
+                                    extended_new:=true;
+                                 end;
+                               hdisposen:
+                                 begin
+                                    secondpass(p^.methodpointer);
+
+                                    { destructor with extended syntax called from dispose }
+                                    { hdisposen always deliver LOC_REFERENCE              }
+                                    exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
+                                      newreference(p^.methodpointer^.location.reference),R_ESI)));
+                                    del_reference(p^.methodpointer^.location.reference);
+                                    exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
+                                    exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L,
+                                    newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0))));
+                                    concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR);
+                                 end;
+                               else
+                                 begin
+                                    { call to an instance member }
+                                    if (p^.symtable^.symtabletype<>withsymtable) then
+                                      begin
+                                         secondpass(p^.methodpointer);
+                                         case p^.methodpointer^.location.loc of
+                                            LOC_REGISTER:
+                                              begin
+                                                 ungetregister32(p^.methodpointer^.location.register);
+                                                 emit_reg_reg(A_MOV,S_L,p^.methodpointer^.location.register,R_ESI);
+                                              end;
+                                            else
+                                              begin
+                                                 if (p^.methodpointer^.resulttype^.deftype=objectdef) and
+                                                   pobjectdef(p^.methodpointer^.resulttype)^.isclass then
+                                                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                                                     newreference(p^.methodpointer^.location.reference),R_ESI)))
+                                                 else
+                                                   exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
+                                                     newreference(p^.methodpointer^.location.reference),R_ESI)));
+                                                 del_reference(p^.methodpointer^.location.reference);
+                                              end;
+                                         end;
+                                      end;
+                                    { when calling a class method, we have
+                                      to load ESI with the VMT !
+                                      But that's wrong, if we call a class method via self
+                                    }
+                                    if ((p^.procdefinition^.options and poclassmethod)<>0)
+                                       and not(p^.methodpointer^.treetype=selfn) then
+                                      begin
+                                         { class method needs current VMT }
+                                         new(r);
+                                         reset_reference(r^);
+                                         r^.base:=R_ESI;
+                                         exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI)));
+                                      end;
+
+                                    exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
+                                    if is_con_or_destructor then
+                                      begin
+                                         { classes don't get a VMT pointer pushed }
+                                         if (p^.methodpointer^.resulttype^.deftype=objectdef) and
+                                           not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) then
+                                           begin
+                                              if ((p^.procdefinition^.options and poconstructor)<>0) then
+                                                begin
+                                                   { it's no bad idea, to insert the VMT }
+                                                   exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L,
+                                                     newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,
+                                                     0))));
+                                                   concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,
+                                                     EXT_NEAR);
+                                                end
+                                              { destructors haven't to dispose the instance, if this is }
+                                              { a direct call                                           }
+                                              else
+                                                push_int(0);
+                                           end;
+                                      end;
+                                 end;
+                             end;
+                          end;
+                     end
+                   else
+                     begin
+                        if ((p^.procdefinition^.options and poclassmethod)<>0) and
+                          not(
+                            assigned(aktprocsym) and
+                            ((aktprocsym^.definition^.options and poclassmethod)<>0)
+                          ) then
+                          begin
+                             { class method needs current VMT }
+                             new(r);
+                             reset_reference(r^);
+                             r^.base:=R_ESI;
+                             exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI)));
+                          end
+                        else
+                          begin
+                             { member call, ESI isn't modified }
+                             loadesi:=false;
+                          end;
+                        exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
+                        { but a con- or destructor here would probably almost }
+                        { always be placed wrong }
+                        if is_con_or_destructor then
+                          begin
+                             Message(cg_w_member_cd_call_from_method);
+                             push_int(0);
+                          end;
+                     end;
+                end;
+
+              { push base pointer ?}
+              if (lexlevel>1) and assigned(pprocdef(p^.procdefinition)^.parast) and
+                ((p^.procdefinition^.parast^.symtablelevel)>2) then
+                begin
+                   { if we call a nested function in a method, we must      }
+                   { push also SELF!                                        }
+                   { THAT'S NOT TRUE, we have to load ESI via frame pointer }
+                   { access                                                 }
+                   {
+                     begin
+                        loadesi:=false;
+                        exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
+                     end;
+                   }
+                   if lexlevel=(p^.procdefinition^.parast^.symtablelevel) then
+                     begin
+                        new(r);
+                        reset_reference(r^);
+                        r^.offset:=procinfo.framepointer_offset;
+                        r^.base:=procinfo.framepointer;
+                        exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,r)))
+                     end
+                     { this is only true if the difference is one !!
+                       but it cannot be more !! }
+                   else if (lexlevel=p^.procdefinition^.parast^.symtablelevel-1) then
+                     begin
+                        exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,procinfo.framepointer)))
+                     end
+                   else if (lexlevel>p^.procdefinition^.parast^.symtablelevel) then
+                     begin
+                        hregister:=getregister32;
+                        new(r);
+                        reset_reference(r^);
+                        r^.offset:=procinfo.framepointer_offset;
+                        r^.base:=procinfo.framepointer;
+                        exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,hregister)));
+                        for i:=(p^.procdefinition^.parast^.symtablelevel) to lexlevel-1 do
+                          begin
+                             new(r);
+                             reset_reference(r^);
+                             {we should get the correct frame_pointer_offset at each level
+                             how can we do this !!! }
+                             r^.offset:=procinfo.framepointer_offset;
+                             r^.base:=hregister;
+                             exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,hregister)));
+                          end;
+                        exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,hregister)));
+                        ungetregister32(hregister);
+                     end
+                   else
+                     internalerror(25000);
+                end;
+
+              { exported methods should be never called direct }
+              if (p^.procdefinition^.options and poexports)<>0 then
+                Message(cg_e_dont_call_exported_direct);
+
+              if (pushedparasize mod 4)<>0 then
+                begin
+                   corr^.op1:=pointer(4-(pushedparasize mod 4));
+                   must_pop:=true;
+                   pop_size:=4-(pushedparasize mod 4);
+                end
+              else
+                begin
+                   exprasmlist^.remove(corr);
+                   must_pop:=false;
+                   pop_size:=0;
+                end;
+
+              if ((p^.procdefinition^.options and povirtualmethod)<>0) and
+                 not(no_virtual_call) then
+                begin
+                   { static functions contain the vmt_address in ESI }
+                   { also class methods                              }
+                   if assigned(aktprocsym) then
+                     begin
+                       if ((aktprocsym^.properties and sp_static)<>0) or
+                        ((aktprocsym^.definition^.options and poclassmethod)<>0) or
+                        ((p^.procdefinition^.options and postaticmethod)<>0) or
+                        { ESI is loaded earlier }
+                        ((p^.procdefinition^.options and poclassmethod)<>0)then
+                         begin
+                            new(r);
+                            reset_reference(r^);
+                            r^.base:=R_ESI;
+                         end
+                       else
+                         begin
+                            new(r);
+                            reset_reference(r^);
+                            r^.base:=R_ESI;
+                            exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI)));
+                            new(r);
+                            reset_reference(r^);
+                            r^.base:=R_EDI;
+                         end;
+                     end
+                   else
+                     begin
+                       new(r);
+                       reset_reference(r^);
+                       r^.base:=R_ESI;
+                       exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI)));
+                       new(r);
+                       reset_reference(r^);
+                       r^.base:=R_EDI;
+                     end;
+                   if p^.procdefinition^.extnumber=-1 then
+                        internalerror($Da);
+                   r^.offset:=p^.procdefinition^.extnumber*4+12;
+                   if (cs_rangechecking in aktswitches) then
+                     begin
+                        exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,r^.base)));
+                        emitcall('CHECK_OBJECT',true);
+                     end;
+                   exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,r)));
+                end
+              else
+                emitcall(p^.procdefinition^.mangledname,
+                  p^.symtableproc^.symtabletype=unitsymtable);
+              if ((p^.procdefinition^.options and poclearstack)<>0) then
+                begin
+                   { consider the alignment with the rest (PM) }
+                   pushedparasize:=pushedparasize+pop_size;
+                   must_pop:=false;
+                   if pushedparasize=4 then
+                     { better than an add on all processors }
+                     exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI)))
+                   { the pentium has two pipes and pop reg is pairable }
+                   { but the registers must be different!              }
+                   else if (pushedparasize=8) and
+                     not(cs_littlesize in aktswitches) and
+                     (opt_processors=pentium) and
+                     (procinfo._class=nil) then
+                       begin
+                          exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI)));
+                          exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_ESI)));
+                       end
+                   else exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,pushedparasize,R_ESP)));
+                end;
+           end
+         else
+           begin
+              if (pushedparasize mod 4)<>0 then
+                begin
+                   corr^.op1:=pointer(4-(pushedparasize mod 4));
+                   must_pop:=true;
+                   pop_size:=4-(pushedparasize mod 4);
+                end
+              else
+                begin
+                   exprasmlist^.remove(corr);
+                   must_pop:=false;
+                   pop_size:=0;
+                end;
+
+              secondpass(p^.right);
+              case p^.right^.location.loc of
+                 LOC_REGISTER,LOC_CREGISTER:
+                    begin
+                        exprasmlist^.concat(new(pai386,op_reg(A_CALL,S_NO,p^.right^.location.register)));
+                        ungetregister32(p^.right^.location.register);
+                    end
+                 else
+                    exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,newreference(p^.right^.location.reference))));
+                    del_reference(p^.right^.location.reference);
+              end;
+
+
+             end;
+      dont_call:
+         pushedparasize:=oldpushedparasize;
+         unused:=unusedregisters;
+
+         { handle function results }
+         if p^.resulttype<>pdef(voiddef) then
+           begin
+
+                 { a contructor could be a function with boolean result }
+              if (p^.right=nil) and
+                 ((p^.procdefinition^.options and poconstructor)<>0) and
+                 { quick'n'dirty check if it is a class or an object }
+                 (p^.resulttype^.deftype=orddef) then
+                begin
+                   p^.location.loc:=LOC_FLAGS;
+                   p^.location.resflags:=F_NE;
+                   if extended_new then
+                     begin
+{$ifdef test_dest_loc}
+                        if dest_loc_known and (dest_loc_tree=p) then
+                          mov_reg_to_dest(p,S_L,R_EAX)
+                        else
+{$endif test_dest_loc}
+                          begin
+                             hregister:=getregister32;
+                             emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
+                             p^.location.register:=hregister;
+                          end;
+                     end;
+                end
+              { structed results are easy to handle.... }
+              else if ret_in_param(p^.resulttype) then
+                begin
+                   p^.location.loc:=LOC_MEM;
+                   stringdispose(p^.location.reference.symbol);
+                   p^.location.reference:=funcretref;
+                    end
+                 else
+                    begin
+                       if (p^.resulttype^.deftype=orddef) then
+                          begin
+                             p^.location.loc:=LOC_REGISTER;
+                             case porddef(p^.resulttype)^.typ of
+                                s32bit,u32bit :
+                                  begin
+{$ifdef test_dest_loc}
+                                     if dest_loc_known and (dest_loc_tree=p) then
+                                       mov_reg_to_dest(p,S_L,R_EAX)
+                                     else
+{$endif test_dest_loc}
+                                       begin
+                                          hregister:=getregister32;
+                                          emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
+                                          p^.location.register:=hregister;
+                                       end;
+                                  end;
+                                uchar,u8bit,bool8bit,s8bit :
+                                  begin
+{$ifdef test_dest_loc}
+                                     if dest_loc_known and (dest_loc_tree=p) then
+                                       mov_reg_to_dest(p,S_B,R_AL)
+                                     else
+{$endif test_dest_loc}
+                                       begin
+                                          hregister:=getregister32;
+                                          emit_reg_reg(A_MOV,S_B,R_AL,reg32toreg8(hregister));
+                                          p^.location.register:=reg32toreg8(hregister);
+                                       end;
+                                  end;
+                                s16bit,u16bit :
+                                  begin
+{$ifdef test_dest_loc}
+                                     if dest_loc_known and (dest_loc_tree=p) then
+                                       mov_reg_to_dest(p,S_W,R_AX)
+                                     else
+{$endif test_dest_loc}
+                                       begin
+                                          hregister:=getregister32;
+                                          emit_reg_reg(A_MOV,S_W,R_AX,reg32toreg16(hregister));
+                                          p^.location.register:=reg32toreg16(hregister);
+                                       end;
+                                  end;
+                             else internalerror(7);
+                              end
+
+                          end
+                       else if (p^.resulttype^.deftype=floatdef) then
+                           case pfloatdef(p^.resulttype)^.typ of
+                                 f32bit : begin
+                                             p^.location.loc:=LOC_REGISTER;
+{$ifdef test_dest_loc}
+                                             if dest_loc_known and (dest_loc_tree=p) then
+                                               mov_reg_to_dest(p,S_L,R_EAX)
+                                             else
+{$endif test_dest_loc}
+                                               begin
+                                                  hregister:=getregister32;
+                                                  emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
+                                                  p^.location.register:=hregister;
+                                               end;
+                                          end;
+                                 else
+                                     p^.location.loc:=LOC_FPU;
+                           end
+                       else
+                          begin
+                              p^.location.loc:=LOC_REGISTER;
+{$ifdef test_dest_loc}
+                              if dest_loc_known and (dest_loc_tree=p) then
+                                mov_reg_to_dest(p,S_L,R_EAX)
+                              else
+{$endif test_dest_loc}
+                                begin
+                                    hregister:=getregister32;
+                                    emit_reg_reg(A_MOV,S_L,R_EAX,hregister);
+                                    p^.location.register:=hregister;
+                                end;
+                          end;
+                end;
+           end;
+
+         { perhaps i/o check ? }
+         if iolabel<>nil then
+           begin
+              exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L,newcsymbol(lab2str(iolabel),0))));
+              { this was wrong, probably an error due to diff3
+                emitcall(p^.procdefinition^.mangledname);}
+              emitcall('IOCHECK',true);
+           end;
+         { this should be optimized (PM) }
+         if must_pop then
+           exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,pop_size,R_ESP)));
+         { restore registers }
+         popusedregisters(pushed);
+
+         { at last, restore instance pointer (SELF) }
+         if loadesi then
+           maybe_loadesi;
+         pp:=params;
+         while assigned(pp) do
+           begin
+              if assigned(pp^.left) then
+                if (pp^.left^.location.loc=LOC_REFERENCE) or
+                  (pp^.left^.location.loc=LOC_MEM) then
+                  ungetiftemp(pp^.left^.location.reference);
+              pp:=pp^.right;
+           end;
+         disposetree(params);
+      end;
+
+    { reverts the parameter list }
+    var nb_para : integer;
+
+    function reversparameter(p : ptree) : ptree;
+
+       var
+         hp1,hp2 : ptree;
+
+      begin
+         hp1:=nil;
+         nb_para := 0;
+         while assigned(p) do
+           begin
+              { pull out }
+              hp2:=p;
+              p:=p^.right;
+              inc(nb_para);
+              { pull in }
+              hp2^.right:=hp1;
+              hp1:=hp2;
+           end;
+         reversparameter:=hp1;
+       end;
+
+    procedure secondinline(var p : ptree);
+     const     in2size:array[in_inc_byte..in_dec_dword] of Topsize=
+                         (S_B,S_W,S_L,S_B,S_W,S_L);
+               in2instr:array[in_inc_byte..in_dec_dword] of Tasmop=
+                         (A_INC,A_INC,A_INC,A_DEC,A_DEC,A_DEC);
+
+            { tfloattype = (f32bit,s32real,s64real,s80real,s64bit); }
+            float_name: array[tfloattype] of string[8]=
+                ('FIXED','SINGLE','REAL','EXTENDED','COMP','FIXED16');
+       var
+         aktfile : treference;
+         ft : tfiletype;
+         opsize : topsize;
+         asmop : tasmop;
+         pushed : tpushed;
+         dummycoll : tdefcoll;
+
+      { produces code for READ(LN) and WRITE(LN) }
+
+      procedure handlereadwrite(doread,callwriteln : boolean);
+
+        procedure loadstream;
+
+          const     io:array[0..1] of string[7]=('_OUTPUT','_INPUT');
+          var     r : preference;
+
+            begin
+                 new(r);
+                 reset_reference(r^);
+                 r^.symbol:=stringdup('U_'+upper(target_info.system_unit)+io[byte(doread)]);
+                 if assem_need_external_list and
+                   not (cs_compilesystem in aktswitches) then
+                 concat_external(r^.symbol^,EXT_NEAR);
+
+                 exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,r,R_EDI)))
+            end;
+
+        var
+             node,hp : ptree;
+            typedtyp,pararesult : pdef;
+           doflush,has_length : boolean;
+           dummycoll : tdefcoll;
+           iolabel : plabel;
+           npara : longint;
+
+        begin
+           { I/O check }
+           if cs_iocheck in aktswitches then
+                begin
+                getlabel(iolabel);
+                emitl(A_LABEL,iolabel);
+             end
+           else iolabel:=nil;
+           { no automatic call from flush }
+           doflush:=false;
+           { for write of real with the length specified }
+           has_length:=false;
+           hp:=nil;
+           { reserve temporary pointer to data variable }
+             aktfile.symbol:=nil;
+           gettempofsizereference(4,aktfile);
+           { first state text data }
+           ft:=ft_text;
+           { and state a parameter ? }
+           if p^.left=nil then
+             begin
+                { state screen address}
+                doflush:=true;
+                { the following instructions are for "writeln;" }
+                loadstream;
+                { save @Dateivarible in temporary variable }
+                exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile))));
+             end
+           else
+             begin
+                { revers paramters }
+                node:=reversparameter(p^.left);
+
+                p^.left := node;
+                npara := nb_para;
+                { calculate data variable }
+                { is first parameter a file type ? }
+                if node^.left^.resulttype^.deftype=filedef then
+                  begin
+                     ft:=pfiledef(node^.left^.resulttype)^.filetype;
+                     if ft=ft_typed then
+                       typedtyp:=pfiledef(node^.left^.resulttype)^.typed_as;
+                     secondpass(node^.left);
+                     if codegenerror then
+                       exit;
+
+                     { save reference in temporary variables }                     { reference in tempor„re Variable retten }
+                     if node^.left^.location.loc<>LOC_REFERENCE then
+                       begin
+                          Message(cg_e_illegal_expression);
+                          exit;
+                       end;
+
+                     exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_EDI)));
+
+                     { skip to the next parameter }
+                     node:=node^.right;
+                  end
+                else
+                  begin
+                     { if we write to stdout/in then flush after the write(ln) }
+                     doflush:=true;
+                     loadstream;
+                  end;
+
+                    { save @Dateivarible in temporary variable }
+                exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile))));
+                if doread then
+                  { parameter by READ gives call by reference }
+                  dummycoll.paratyp:=vs_var
+                { an WRITE Call by "Const" }
+                else dummycoll.paratyp:=vs_const;
+
+                { because of secondcallparan, which otherwise attaches }
+                if ft=ft_typed then
+                  begin
+                     { this is to avoid copy of simple const parameters }
+                     dummycoll.data:=new(pformaldef,init);
+                  end
+                else
+                  { I think, this isn't a good solution (FK) }
+                  dummycoll.data:=nil;
+
+                while assigned(node) do
+                  begin
+                     pushusedregisters(pushed,$ff);
+                     hp:=node;
+                     node:=node^.right;
+                     hp^.right:=nil;
+                     if hp^.is_colon_para then
+                       Message(parser_e_illegal_colon_qualifier);
+                     if ft=ft_typed then
+                       never_copy_const_param:=true;
+                     secondcallparan(hp,@dummycoll,false);
+                     if ft=ft_typed then
+                       never_copy_const_param:=false;
+                     hp^.right:=node;
+                          if codegenerror then
+                       exit;
+
+                     emit_push_mem(aktfile);
+                     if (ft=ft_typed) then
+                       begin
+                          { OK let's try this }
+                          { first we must only allow the right type }
+                            { we have to call blockread or blockwrite }
+                                   { but the real problem is that            }
+                            { reset and rewrite should have set       }
+                            { the type size                           }
+                                   { as recordsize for that file !!!!        }
+                            { how can we make that                    }
+                            { I think that is only possible by adding }
+                            { reset and rewrite to the inline list a call        }
+                                   { allways read only one record by element }
+                            push_int(typedtyp^.size);
+                            if doread then
+                              emitcall('TYPED_READ',true)
+                            else
+                              emitcall('TYPED_WRITE',true)
+                          {!!!!!!!}
+                       end
+                     else
+                       begin
+                          { save current position }
+                          pararesult:=hp^.left^.resulttype;
+                          { handle possible field width  }
+                          { of course only for write(ln) }
+                          if not doread then
+                               begin
+                               { handle total width parameter }
+                               if assigned(node) and node^.is_colon_para then
+                                 begin
+                                    hp:=node;
+                                    node:=node^.right;
+                                    hp^.right:=nil;
+                                    secondcallparan(hp,@dummycoll,false);
+                                    hp^.right:=node;
+                                    if codegenerror then
+                                      exit;
+                                    has_length:=true;
+                                 end
+                               else
+                                 if pararesult^.deftype<>floatdef then
+                                   push_int(0)
+                                 else
+                                  push_int(-32767);
+                              { a second colon para for a float ? }
+                              if assigned(node) and node^.is_colon_para then
+                                begin
+                                    hp:=node;
+                                    node:=node^.right;
+                                    hp^.right:=nil;
+                                    secondcallparan(hp,@dummycoll,false);
+                                    hp^.right:=node;
+                                    if pararesult^.deftype<>floatdef then
+                                      Message(parser_e_illegal_colon_qualifier);
+                                    if codegenerror then
+                                      exit;
+                                end
+                              else
+                                begin
+                                if pararesult^.deftype=floatdef then
+                                    push_int(-1);
+                                end
+                              end;
+                          case pararesult^.deftype of
+                                    stringdef : begin
+                                                       if doread then
+                                                         emitcall('READ_TEXT_STRING',true)
+                                                       else
+                                                         begin
+                                                            emitcall('WRITE_TEXT_STRING',true);
+                                      {ungetiftemp(hp^.left^.location.reference);}
+                                   end;
+                                                   end;
+                                    pointerdef : begin
+                                                        if is_equal(ppointerdef(pararesult)^.definition,cchardef) then
+                                                          begin
+                                                              if doread then
+                                                                 emitcall('READ_TEXT_PCHAR_AS_POINTER',true)
+                                                              else
+                                                                 emitcall('WRITE_TEXT_PCHAR_AS_POINTER',true);
+                                                          end
+                                                        else
+                                                         Message(parser_e_illegal_parameter_list);
+                                                    end;
+                                    arraydef : begin
+                                                     if (parraydef(pararesult)^.lowrange=0)
+                                                        and is_equal(parraydef(pararesult)^.definition,cchardef) then
+                                                        begin
+                                                            if doread then
+                                                                 emitcall('READ_TEXT_PCHAR_AS_ARRAY',true)
+                                                            else
+                                                                 emitcall('WRITE_TEXT_PCHAR_AS_ARRAY',true);
+                                                        end
+                                                     else
+                                                      Message(parser_e_illegal_parameter_list);
+                                                  end;
+
+                                    floatdef : begin
+                                                  if doread then
+                                                    emitcall('READ_TEXT_REAL',true)
+                                                  else
+                                                    emitcall('WRITE_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true);
+                                               end;
+                                    orddef : begin
+                                                     case porddef(pararesult)^.typ of
+                                                         u8bit : if doread then
+                                                                       emitcall('READ_TEXT_BYTE',true);
+                                                         s8bit : if doread then
+                                                                       emitcall('READ_TEXT_SHORTINT',true);
+                                                         u16bit : if doread then
+                                                                       emitcall('READ_TEXT_WORD',true);
+                                                         s16bit : if doread then
+                                                                       emitcall('READ_TEXT_INTEGER',true);
+                                                         s32bit : if doread then
+                                                                       emitcall('READ_TEXT_LONGINT',true)
+                                                                    else
+                                                                       emitcall('WRITE_TEXT_LONGINT',true);
+                                                         u32bit : if doread then
+                                                                       emitcall('READ_TEXT_CARDINAL',true)
+                                                                    else
+                                                                       emitcall('WRITE_TEXT_CARDINAL',true);
+                                                         uchar : if doread then
+                                                                       emitcall('READ_TEXT_CHAR',true)
+                                                                    else
+                                                                       emitcall('WRITE_TEXT_CHAR',true);
+                                                         bool8bit : if  doread then
+                                                                       { emitcall('READ_TEXT_BOOLEAN',true) }
+                                                                       Message(parser_e_illegal_parameter_list)
+                                                                    else
+                                                                       emitcall('WRITE_TEXT_BOOLEAN',true);
+                                                         else Message(parser_e_illegal_parameter_list);
+                                                         end;
+                                                     end;
+                                    else Message(parser_e_illegal_parameter_list);
+                                end;
+                            end;
+                          { load ESI in methods again }
+                          popusedregisters(pushed);
+                          maybe_loadesi;
+                  end;
+             end;
+           if callwriteln then
+             begin
+                pushusedregisters(pushed,$ff);
+                emit_push_mem(aktfile);
+                { pushexceptlabel; }
+                if ft<>ft_text then
+                  Message(parser_e_illegal_parameter_list)                                    ;
+                emitcall('WRITELN_TEXT',true);
+                popusedregisters(pushed);
+                maybe_loadesi;
+             end;
+           if doflush and not(doread) then
+             begin
+                pushusedregisters(pushed,$ff);
+                { pushexceptlabel; }
+                emitcall('FLUSH_STDOUT',true);
+                popusedregisters(pushed);
+                maybe_loadesi;
+             end;
+           if iolabel<>nil then
+             begin
+                { registers are saved in the procedure }
+                exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L,newcsymbol(lab2str(iolabel),0))));
+                emitcall('IOCHECK',true);
+             end;
+           ungetiftemp(aktfile);
+           if assigned(p^.left) then
+             begin
+                p^.left:=reversparameter(p^.left);
+                    if npara<>nb_para then
+                     Message(cg_f_internal_error_in_secondinline);
+                    hp:=p^.left;
+                    while assigned(hp) do
+                  begin
+                     if assigned(hp^.left) then
+                       if (hp^.left^.location.loc=LOC_REFERENCE) or
+                         (hp^.left^.location.loc=LOC_MEM) then
+                         ungetiftemp(hp^.left^.location.reference);
+                     hp:=hp^.right;
+                  end;
+            end;
+        end;
+
+      procedure handle_str;
+
+        var
+           hp,node,lentree,paratree : ptree;
+           dummycoll : tdefcoll;
+           is_real,has_length : boolean;
+           real_type : byte;
+
+          begin
+           pushusedregisters(pushed,$ff);
+           node:=p^.left;
+           is_real:=false;
+           has_length:=false;
+           while assigned(node^.right) do node:=node^.right;
+           { if a real parameter somewhere then call REALSTR }
+           if (node^.left^.resulttype^.deftype=floatdef) then
+             is_real:=true;
+
+           node:=p^.left;
+           { we have at least two args }
+           { with at max 2 colon_para in between }
+
+           { first arg longint or float }
+           hp:=node;
+           node:=node^.right;
+           hp^.right:=nil;
+           dummycoll.data:=hp^.resulttype;
+           { string arg }
+
+           dummycoll.paratyp:=vs_var;
+           secondcallparan(hp,@dummycoll,false);
+           if codegenerror then
+             exit;
+
+           dummycoll.paratyp:=vs_const;
+           { second arg }
+           hp:=node;
+           node:=node^.right;
+           hp^.right:=nil;
+           { frac  para }
+           if hp^.is_colon_para and assigned(node) and
+              node^.is_colon_para then
+             begin
+                dummycoll.data:=hp^.resulttype;
+                secondcallparan(hp,@dummycoll,false);
+                if codegenerror then
+                  exit;
+                hp:=node;
+                node:=node^.right;
+                hp^.right:=nil;
+                has_length:=true;
+             end
+           else
+             if is_real then
+             push_int(-1);
+
+           { third arg, length only if is_real }
+           if hp^.is_colon_para then
+             begin
+                dummycoll.data:=hp^.resulttype;
+                secondcallparan(hp,@dummycoll,false);
+                if codegenerror then
+                  exit;
+                hp:=node;
+                node:=node^.right;
+                hp^.right:=nil;
+             end
+           else
+             if is_real then
+               push_int(-32767)
+             else
+               push_int(-1);
+
+           { last arg longint or real }
+           secondcallparan(hp,@dummycoll,false);
+           if codegenerror then
+             exit;
+
+           if is_real then
+             emitcall('STR_'+float_name[pfloatdef(hp^.resulttype)^.typ],true)
+           else if porddef(hp^.resulttype)^.typ=u32bit then
+             emitcall('STR_CARDINAL',true)
+           else
+             emitcall('STR_LONGINT',true);
+           popusedregisters(pushed);
+        end;
+
+      var
+         r : preference;
+
+      begin
+         case p^.inlinenumber of
+            in_lo_word,
+            in_hi_word :
+              begin
+                 secondpass(p^.left);
+                 p^.location.loc:=LOC_REGISTER;
+                 if p^.left^.location.loc<>LOC_REGISTER then
+                   begin
+                     if p^.left^.location.loc=LOC_CREGISTER then
+                       begin
+                          p^.location.register:=reg32toreg16(getregister32);
+                          emit_reg_reg(A_MOV,S_W,p^.left^.location.register,
+                            p^.location.register);
+                       end
+                     else
+                       begin
+                          del_reference(p^.left^.location.reference);
+                          p^.location.register:=reg32toreg16(getregister32);
+                          exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W,newreference(p^.left^.location.reference),
+                            p^.location.register)));
+                       end;
+                   end
+                 else p^.location.register:=p^.left^.location.register;
+                 if p^.inlinenumber=in_hi_word then
+                   exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_W,8,p^.location.register)));
+                 p^.location.register:=reg16toreg8(p^.location.register);
+              end;
+            in_high_x :
+              begin
+                 if is_open_array(p^.left^.resulttype) then
+                   begin
+                      secondpass(p^.left);
+                      del_reference(p^.left^.location.reference);
+                      p^.location.register:=getregister32;
+                      new(r);
+                      reset_reference(r^);
+                      r^.base:=highframepointer;
+                      r^.offset:=highoffset+4;
+                      exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                        r,p^.location.register)));
+                   end
+              end;
+            in_sizeof_x,
+            in_typeof_x :
+              begin
+                 { for both cases load vmt }
+                 if p^.left^.treetype=typen then
+                   begin
+                      p^.location.register:=getregister32;
+                      exprasmlist^.concat(new(pai386,op_csymbol_reg(A_MOV,
+                        S_L,newcsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,0),
+                        p^.location.register)));
+                   end
+                 else
+                   begin
+                      secondpass(p^.left);
+                      del_reference(p^.left^.location.reference);
+                      p^.location.loc:=LOC_REGISTER;
+                      p^.location.register:=getregister32;
+                      { load VMT pointer }
+                      exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                      newreference(p^.left^.location.reference),
+                        p^.location.register)));
+                   end;
+                 { in sizeof load size }
+                 if p^.inlinenumber=in_sizeof_x then
+                   begin
+                      new(r);
+                      reset_reference(r^);
+                      r^.base:=p^.location.register;
+                      exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,
+                        p^.location.register)));
+                   end;
+              end;
+            in_lo_long,
+            in_hi_long :
+              begin
+                 secondpass(p^.left);
+                 p^.location.loc:=LOC_REGISTER;
+                 if p^.left^.location.loc<>LOC_REGISTER then
+                   begin
+                      if p^.left^.location.loc=LOC_CREGISTER then
+                        begin
+                           p^.location.register:=getregister32;
+                           emit_reg_reg(A_MOV,S_L,p^.left^.location.register,
+                             p^.location.register);
+                        end
+                      else
+                        begin
+                           del_reference(p^.left^.location.reference);
+                           p^.location.register:=getregister32;
+                           exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
+                             p^.location.register)));
+                        end;
+                   end
+                 else p^.location.register:=p^.left^.location.register;
+                 if p^.inlinenumber=in_hi_long then
+                   exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_L,16,p^.location.register)));
+                 p^.location.register:=reg32toreg16(p^.location.register);
+              end;
+{***CHARBUG}
+{We can now comment them out, as they are handled as typecast.
+ Saves an incredible amount of 8 bytes code.
+ I'am not lucky about this, because it's _not_ a type cast (FK) }
+{              in_ord_char,
+               in_chr_byte,}
+{***}
+            in_length_string :
+              begin
+                 secondpass(p^.left);
+                 set_location(p^.location,p^.left^.location);
+              end;
+            in_pred_x,
+            in_succ_x:
+              begin
+                 secondpass(p^.left);
+                 if p^.inlinenumber=in_pred_x then
+                   asmop:=A_DEC
+                 else
+                   asmop:=A_INC;
+                 case p^.resulttype^.size of
+                   4 : opsize:=S_L;
+                   2 : opsize:=S_W;
+                   1 : opsize:=S_B;
+                 else
+                   internalerror(10080);
+                 end;
+                 p^.location.loc:=LOC_REGISTER;
+                 if p^.left^.location.loc<>LOC_REGISTER then
+                   begin
+                      p^.location.register:=getregister32;
+                      if (p^.resulttype^.size=2) then
+                        p^.location.register:=reg32toreg16(p^.location.register);
+                      if (p^.resulttype^.size=1) then
+                        p^.location.register:=reg32toreg8(p^.location.register);
+                      if p^.left^.location.loc=LOC_CREGISTER then
+                        emit_reg_reg(A_MOV,opsize,p^.left^.location.register,
+                          p^.location.register)
+                      else
+                      if p^.left^.location.loc=LOC_FLAGS then
+                        exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.left^.location.resflags],S_NO,
+                                  p^.location.register)))
+                      else
+                        begin
+                           del_reference(p^.left^.location.reference);
+                           exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.left^.location.reference),
+                             p^.location.register)));
+                        end;
+                   end
+                 else p^.location.register:=p^.left^.location.register;
+                 exprasmlist^.concat(new(pai386,op_reg(asmop,opsize,
+                   p^.location.register)))
+                 { here we should insert bounds check ? }
+                 { and direct call to bounds will crash the program }
+                 { if we are at the limit }
+                 { we could also simply say that pred(first)=first and succ(last)=last }
+                 { could this be usefull I don't think so (PM)
+                 emitoverflowcheck;}
+              end;
+            in_inc_byte..in_dec_dword:
+              begin
+                 secondpass(p^.left);
+                 exprasmlist^.concat(new(pai386,op_ref(in2instr[p^.inlinenumber],
+                   in2size[p^.inlinenumber],newreference(p^.left^.location.reference))));
+                 emitoverflowcheck;
+              end;
+            in_assigned_x :
+              begin
+                 secondpass(p^.left^.left);
+                 p^.location.loc:=LOC_FLAGS;
+                 if (p^.left^.left^.location.loc=LOC_REGISTER) or
+                    (p^.left^.left^.location.loc=LOC_CREGISTER) then
+                   begin
+                      exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L,
+                        p^.left^.left^.location.register,
+                        p^.left^.left^.location.register)));
+                      ungetregister32(p^.left^.left^.location.register);
+                   end
+                 else
+                   begin
+                      exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_L,0,
+                        newreference(p^.left^.left^.location.reference))));
+                      del_reference(p^.left^.left^.location.reference);
+                   end;
+                 p^.location.resflags:=F_NE;
+              end;
+             in_reset_typedfile,in_rewrite_typedfile :
+               begin
+                  pushusedregisters(pushed,$ff);
+                  exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,pfiledef(p^.left^.resulttype)^.typed_as^.size)));
+                  secondload(p^.left);
+                  emitpushreferenceaddr(p^.left^.location.reference);
+                  if p^.inlinenumber=in_reset_typedfile then
+                    emitcall('RESET_TYPED',true)
+                  else
+                    emitcall('REWRITE_TYPED',true);
+                  popusedregisters(pushed);
+               end;
+            in_write_x :
+              handlereadwrite(false,false);
+            in_writeln_x :
+              handlereadwrite(false,true);
+            in_read_x :
+              handlereadwrite(true,false);
+            in_readln_x :
+              begin
+                handlereadwrite(true,false);
+                pushusedregisters(pushed,$ff);
+                emit_push_mem(aktfile);
+                { pushexceptlabel; }
+                if ft<>ft_text then
+                  Message(parser_e_illegal_parameter_list);
+                emitcall('READLN_TEXT',true);
+                popusedregisters(pushed);
+                maybe_loadesi;
+              end;
+            in_str_x_string :
+              begin
+                 handle_str;
+                 maybe_loadesi;
+              end;
+            else internalerror(9);
+         end;
+      end;
+
+    procedure secondsubscriptn(var p : ptree);
+
+      var
+         hr : tregister;
+
+      begin
+         secondpass(p^.left);
+
+         if codegenerror then
+             exit;
+         { classes must be dereferenced implicit }
+         if (p^.left^.resulttype^.deftype=objectdef) and
+           pobjectdef(p^.left^.resulttype)^.isclass then
+           begin
+             clear_reference(p^.location.reference);
+             case p^.left^.location.loc of
+                LOC_REGISTER:
+                  p^.location.reference.base:=p^.left^.location.register;
+                LOC_CREGISTER:
+                  begin
+                     { ... and reserve one for the pointer }
+                     hr:=getregister32;
+                     emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr);
+                       p^.location.reference.base:=hr;
+                  end;
+                else
+                  begin
+                     { free register }
+                     del_reference(p^.left^.location.reference);
+
+                     { ... and reserve one for the pointer }
+                     hr:=getregister32;
+                     exprasmlist^.concat(new(pai386,op_ref_reg(
+                       A_MOV,S_L,newreference(p^.left^.location.reference),
+                       hr)));
+                     p^.location.reference.base:=hr;
+                  end;
+             end;
+           end
+         else
+           set_location(p^.location,p^.left^.location);
+
+         inc(p^.location.reference.offset,p^.vs^.address);
+      end;
+
+    procedure secondselfn(var p : ptree);
+
+      begin
+         clear_reference(p^.location.reference);
+         if (p^.resulttype^.deftype=classrefdef) or
+           ((p^.resulttype^.deftype=objectdef)
+             and pobjectdef(p^.resulttype)^.isclass
+           ) then
+           p^.location.register:=R_ESI
+         else
+           p^.location.reference.base:=R_ESI;
+      end;
+
+    procedure secondhdisposen(var p : ptree);
+
+      begin
+         secondpass(p^.left);
+
+         if codegenerror then
+           exit;
+         clear_reference(p^.location.reference);
+         case p^.left^.location.loc of
+            LOC_REGISTER,
+            LOC_CREGISTER:
+              begin
+                 p^.location.reference.index:=getregister32;
+                 exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,
+                   p^.left^.location.register,
+                   p^.location.reference.index)));
+              end;
+            LOC_MEM,LOC_REFERENCE :
+                            begin
+                               del_reference(p^.left^.location.reference);
+                               p^.location.reference.index:=getregister32;
+                               exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
+                                 p^.location.reference.index)));
+                            end;
+         end;
+      end;
+
+    procedure secondhnewn(var p : ptree);
+
+      begin
+       end;
+
+    procedure secondnewn(var p : ptree);
+
+      begin
+         secondpass(p^.left);
+
+           if codegenerror then
+           exit;
+
+         p^.location.register:=p^.left^.location.register;
+      end;
+
+    procedure secondsimplenewdispose(var p : ptree);
+
+      var
+         pushed : tpushed;
+      begin
+         secondpass(p^.left);
+         if codegenerror then
+           exit;
+
+         pushusedregisters(pushed,$ff);
+         { determines the size of the mem block }
+         push_int(ppointerdef(p^.left^.resulttype)^.definition^.size);
+
+         { push pointer adress }
+         case p^.left^.location.loc of
+            LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,
+              p^.left^.location.register)));
+            LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference);
+
+         end;
+
+         { call the mem handling procedures }
+         case p^.treetype of
+           simpledisposen:
+             emitcall('FREEMEM',true);
+           simplenewn:
+             emitcall('GETMEM',true);
+         end;
+
+         popusedregisters(pushed);
+           { may be load ESI }
+           maybe_loadesi;
+       end;
+
+     { copies p a set element on the stack }
+
+     procedure pushsetelement(var p : ptree);
+
+      var
+         hr : tregister;
+
+      begin
+           { copy the element on the stack, slightly complicated }
+         case p^.location.loc of
+               LOC_REGISTER,
+            LOC_CREGISTER : begin
+                              hr:=p^.location.register;
+                              case hr of
+                                 R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP :
+                                   begin
+                                      ungetregister32(hr);
+                                      exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,reg32toreg16(hr))));
+                                   end;
+                                 R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP :
+                                   begin
+                                      ungetregister32(reg16toreg32(hr));
+                                      exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,hr)));
+                                   end;
+                                 R_AL,R_BL,R_CL,R_DL :
+                                   begin
+                                      ungetregister32(reg8toreg32(hr));
+                                      exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,reg8toreg16(hr))));
+                                   end;
+                              end;
+                           end;
+            else
+               begin
+                  exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_W,newreference(p^.location.reference))));
+                  del_reference(p^.location.reference);
+               end;
+         end;
+      end;
+
+    procedure secondsetcons(var p : ptree);
+
+      var
+         l : plabel;
+         i,smallsetvalue : longint;
+         hp : ptree;
+         href,sref : treference;
+
+      begin
+         { this should be reimplemented for smallsets }
+         { differently  (PM) }
+         { produce constant part }
+         href.symbol := Nil;
+         clear_reference(href);
+         getlabel(l);
+         href.symbol:=stringdup(lab2str(l));
+         stringdispose(p^.location.reference.symbol);
+         datasegment^.concat(new(pai_label,init(l)));
+           {if psetdef(p^.resulttype)=smallset then
+           begin
+              smallsetvalue:=(p^.constset^[3]*256)+p^.constset^[2];
+              smallsetvalue:=((smallset*256+p^.constset^[1])*256+p^.constset^[1];
+              datasegment^.concat(new(pai_const,init_32bit(smallsetvalue)));
+              hp:=p^.left;
+              if assigned(hp) then
+                begin
+                   sref.symbol:=nil;
+                   gettempofsizereference(32,sref);
+                     concatcopy(href,sref,32,false);
+                   while assigned(hp) do
+                     begin
+                        secondpass(hp^.left);
+                        if codegenerror then
+                          exit;
+
+                        pushsetelement(hp^.left);
+                        emitpushreferenceaddr(sref);
+                         register is save in subroutine
+                        emitcall('SET_SET_BYTE',true);
+                        hp:=hp^.right;
+                     end;
+                   p^.location.reference:=sref;
+                end
+              else p^.location.reference:=href;
+           end
+         else    }
+           begin
+           for i:=0 to 31 do
+             datasegment^.concat(new(pai_const,init_8bit(p^.constset^[i])));
+         hp:=p^.left;
+         if assigned(hp) then
+           begin
+              sref.symbol:=nil;
+              gettempofsizereference(32,sref);
+                concatcopy(href,sref,32,false);
+              while assigned(hp) do
+                begin
+                   secondpass(hp^.left);
+                   if codegenerror then
+                     exit;
+
+                   pushsetelement(hp^.left);
+                   emitpushreferenceaddr(sref);
+                   { register is save in subroutine }
+                   emitcall('SET_SET_BYTE',true);
+                   hp:=hp^.right;
+                end;
+              p^.location.reference:=sref;
+           end
+         else p^.location.reference:=href;
+         end;
+      end;
+
+    { could be built into secondadd but it }
+    { should be easy to read }
+    procedure secondin(var p : ptree);
+
+
+       type    Tsetpart=record
+                    range:boolean;      {Part is a range.}
+                    start,stop:byte;    {Start/stop when range; Stop=element
+                                              when an element.}
+               end;
+
+       var
+           pushed,ranges : boolean;
+           hr : tregister;
+           setparts:array[1..8] of Tsetpart;
+           i,numparts:byte;
+           href,href2:Treference;
+           l,l2 : plabel;
+
+
+               function analizeset(Aset:Pconstset):boolean;
+
+               var  compares,maxcompares:word;
+                    i:byte;
+
+               type byteset=set of byte;
+
+               begin
+                    analizeset:=false;
+                    ranges:=false;
+                    numparts:=0;
+                    compares:=0;
+                    {Lots of comparisions take a lot of time, so do not allow
+                     too much comparisions. 8 comparisions are, however, still
+                     smalller than emitting the set.}
+                    maxcompares:=5;
+                    if cs_littlesize in aktswitches then
+                         maxcompares:=8;
+                    for i:=0 to 255 do
+                         if i in byteset(Aset^) then
+                              begin
+                                   if (numparts=0) or
+                                    (i<>setparts[numparts].stop+1) then
+                                        begin
+                                             {Set element is a separate element.}
+                                             inc(compares);
+                                             if compares>maxcompares then
+                                                  exit;
+                                             inc(numparts);
+                                             setparts[numparts].range:=false;
+                                             setparts[numparts].stop:=i;
+                                        end
+                                    else
+                                        {Set element is part of a range.}
+                                        if not setparts[numparts].range then
+                                             begin
+                                                  {Transform an element into a range.}
+                                                  setparts[numparts].range:=true;
+                                                  setparts[numparts].start:=
+                                                   setparts[numparts].stop;
+                                                  setparts[numparts].stop:=i;
+                                                  inc(compares);
+                                                  if compares>maxcompares then
+                                                       exit;
+                                             end
+                                        else
+                                             begin
+                                                  {Extend a range.}
+                                                  setparts[numparts].stop:=i;
+                                                  {A range of two elements can better
+                                                   be checked as two separate ones.
+                                                   When extending a range, our range
+                                                   becomes larger than two elements.}
+                                                  ranges:=true;
+                                             end;
+                              end;
+                    analizeset:=true;
+               end;
+
+       begin
+           if psetdef(p^.right^.resulttype)^.settype=smallset then
+             begin
+                 if p^.left^.treetype=ordconstn then
+                    begin
+                       { only compulsory }
+                       secondpass(p^.left);
+                            secondpass(p^.right);
+                       if codegenerror then
+                          exit;
+                       p^.location.resflags:=F_NE;
+                       case p^.right^.location.loc of
+                          LOC_REGISTER,LOC_CREGISTER:
+                            begin
+                               exprasmlist^.concat(new(pai386,op_const_reg(
+                                 A_TEST,S_L,1 shl (p^.left^.value and 31),
+                                 p^.right^.location.register)));
+                               ungetregister32(p^.right^.location.register);
+                            end
+                          else
+                            begin
+                               exprasmlist^.concat(new(pai386,op_const_ref(A_TEST,S_L,1 shl (p^.left^.value and 31),
+                                 newreference(p^.right^.location.reference))));
+                               del_reference(p^.right^.location.reference);
+                            end;
+                       end;
+                    end
+                 else
+                    begin
+                       { calculate both operators }
+                       { the complex one first }
+                       firstcomplex(p);
+                       secondpass(p^.left);
+                       { are too few registers free? }
+                       pushed:=maybe_push(p^.right^.registers32,p^.left);
+                       secondpass(p^.right);
+                       if pushed then
+                          restore(p^.left);
+                       { of course not commutative }
+                       if p^.swaped then
+                              swaptree(p);
+                       case p^.left^.location.loc of
+                         LOC_REGISTER,
+                         LOC_CREGISTER:
+                           begin
+                              hr:=p^.left^.location.register;
+                              case p^.left^.location.register of
+                                 R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP :
+                                    begin
+                                        hr:=reg16toreg32(p^.left^.location.register);
+                                        ungetregister32(hr);
+                                        exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,
+                                          p^.left^.location.register,hr)));
+                                    end;
+                                 R_AL,R_BL,R_CL,R_DL :
+                                    begin
+                                        hr:=reg8toreg32(p^.left^.location.register);
+                                        ungetregister32(hr);
+                                        exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,
+                                          p^.left^.location.register,hr)));
+                                    end;
+                              end;
+                           end;
+                         else
+                             begin
+                                 { the set element isn't never samller than a byte  }
+                                 { and because it's a small set we need only 5 bits }
+                                 { but 8 bits are eaiser to load                    }
+                                 exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,
+                                   newreference(p^.left^.location.reference),R_EDI)));
+                                 hr:=R_EDI;
+                                 del_reference(p^.left^.location.reference);
+                             end;
+                       end;
+                       case p^.right^.location.loc of
+                         LOC_REGISTER,
+                         LOC_CREGISTER:
+                           exprasmlist^.concat(new(pai386,op_reg_reg(A_BT,S_L,hr,
+                             p^.right^.location.register)));
+                         else
+                            begin
+                               exprasmlist^.concat(new(pai386,op_reg_ref(A_BT,S_L,hr,
+                                 newreference(p^.right^.location.reference))));
+                                        del_reference(p^.right^.location.reference);
+                            end;
+                       end;
+                       p^.location.loc:=LOC_FLAGS;
+                       p^.location.resflags:=F_C;
+                    end;
+             end
+           else
+             begin
+                 if p^.left^.treetype=ordconstn then
+                    begin
+                       { only compulsory }
+                       secondpass(p^.left);
+                       secondpass(p^.right);
+                       if codegenerror then
+                          exit;
+                       p^.location.resflags:=F_NE;
+                       inc(p^.right^.location.reference.offset,p^.left^.value shr 3);
+                       exprasmlist^.concat(new(pai386,op_const_ref(A_TEST,S_B,1 shl (p^.left^.value and 7),
+                          newreference(p^.right^.location.reference))));
+                       del_reference(p^.right^.location.reference);
+                    end
+                 else
+                    begin
+                       if (p^.right^.treetype=setconstrn) and
+                         analizeset(p^.right^.constset) then
+                         begin
+                            {It gives us advantage to check for the set elements
+                             separately instead of using the SET_IN_BYTE procedure.
+                             To do: Build in support for LOC_JUMP.}
+                            secondpass(p^.left);
+                            {We won't do a second pass on p^.right, because
+                             this will emit the constant set.}
+                            {If register is used, use only lower 8 bits}
+
+                            case p^.left^.location.loc of
+                               LOC_REGISTER,
+                               LOC_CREGISTER :
+                                 exprasmlist^.concat(new(pai386,op_const_reg(A_AND,S_B,
+                                   255,p^.left^.location.register)));
+                            end;
+                            {Get a label to jump to the end.}
+                            p^.location.loc:=LOC_FLAGS;
+                            {It's better to use the zero flag when there are
+                             no ranges.}
+                            if ranges then
+                              p^.location.resflags:=F_C
+                            else
+                              p^.location.resflags:=F_E;
+                            href.symbol := nil;
+                            clear_reference(href);
+                            getlabel(l);
+                            href.symbol:=stringdup(lab2str(l));
+                            for i:=1 to numparts do
+                              if setparts[i].range then
+                                begin
+                                   {Check if left is in a range.}
+                                   {Get a label to jump over the check.}
+                                   href2.symbol := nil;
+                                   clear_reference(href2);
+                                   getlabel(l2);
+                                   href.symbol:=stringdup(lab2str(l2));
+                                   if setparts[i].start=setparts[i].stop-1 then
+                                     begin
+                                        case p^.left^.location.loc of
+                                           LOC_REGISTER,
+                                           LOC_CREGISTER :
+                                             exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,S_B,
+                                               setparts[i].start,p^.left^.location.register)));
+                                           else
+                                             exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B,
+                                               setparts[i].start,newreference(p^.left^.location.reference))));
+                                        end;
+                                        {Result should be in carry flag when ranges are used.}
+                                        if ranges then
+                                          exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO)));
+                                        {If found, jump to end.}
+                                        emitl(A_JE,l);
+                                        case p^.left^.location.loc of
+                                           LOC_REGISTER,
+                                           LOC_CREGISTER:
+                                             exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,S_B,
+                                               setparts[i].stop,p^.left^.location.register)));
+                                           else
+                                             exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B,
+                                               setparts[i].stop,newreference(p^.left^.location.reference))));
+                                        end;
+                                        {If found, jump to end.}
+                                        emitl(A_JE,l);
+                                     end
+                                   else
+                                     begin
+                                        if setparts[i].start<>0 then
+                                          begin
+                                             { We only check for the lower bound if it is > 0, because
+                                             set elements lower than 0 do nt exist.}
+                                             case p^.left^.location.loc of
+                                               LOC_REGISTER,
+                                               LOC_CREGISTER :
+                                                 exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,S_B,
+                                                 setparts[i].start,p^.left^.location.register)));
+                                               else
+                                                 exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B,
+                                               setparts[i].start,newreference(p^.left^.location.reference))));
+                                             end;
+                                             {If lower, jump to next check.}
+                                             emitl(A_JB,l2);
+                                          end;
+                                        if setparts[i].stop<>255 then
+                                          begin
+                                             { We only check for the high bound if it is < 255, because
+                                               set elements higher than 255 do nt exist.}
+                                             case p^.left^.location.loc of
+                                               LOC_REGISTER,
+                                               LOC_CREGISTER :
+                                                 exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,S_B,
+                                                   setparts[i].stop+1,p^.left^.location.register)));
+                                               else
+                                                 exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B,
+                                                   setparts[i].stop+1,newreference(p^.left^.location.reference))));
+                                             end;
+                                             {If higher, element is in set.}
+                                             emitl(A_JB,l);
+                                          end;
+                                      end;
+                                   {Emit the jump over label.}
+                                   exprasmlist^.concat(new(pai_label,init(l2)));
+                                end
+                              else
+                                begin
+                                   {Emit code to check if left is an element.}
+                                   case p^.left^.location.loc of
+                                      LOC_REGISTER,
+                                      LOC_CREGISTER:
+                                        exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,S_B,
+                                          setparts[i].stop,p^.left^.location.register)));
+                                      else
+                                        exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B,
+                                          setparts[i].stop,newreference(p^.left^.location.reference))));
+                                   end;
+                                   {Result should be in carry flag when ranges are used.}
+                                   if ranges then
+                                     exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO)));
+                                   {If found, jump to end.}
+                                   emitl(A_JE,l);
+                                end;
+                            if ranges then
+                              exprasmlist^.concat(new(pai386,op_none(A_CLC,S_NO)));
+                            {To compensate for not doing a second pass.}
+                            stringdispose(p^.right^.location.reference.symbol);
+                            {Now place the end label.}
+                            exprasmlist^.concat(new(pai_label,init(l)));
+                            case p^.left^.location.loc of
+                               LOC_REGISTER,
+                               LOC_CREGISTER:
+                                 ungetregister32(p^.left^.location.register);
+                               else
+                                 del_reference(p^.left^.location.reference);
+                            end;
+                         end
+                       else
+                         begin
+                            { calculate both operators }
+                            { the complex one first }
+                            firstcomplex(p);
+                            secondpass(p^.left);
+                            { are too few registers free? }
+                            pushed:=maybe_push(p^.right^.registers32,p);
+                            secondpass(p^.right);
+                            if pushed then restore(p);
+                            { of course not commutative }
+                            if p^.swaped then
+                              swaptree(p);
+                            pushsetelement(p^.left);
+                            emitpushreferenceaddr(p^.right^.location.reference);
+                            del_reference(p^.right^.location.reference);
+                            { registers need not be save. that happens in SET_IN_BYTE }
+                            { (EDI is changed) }
+                            emitcall('SET_IN_BYTE',true);
+                            { ungetiftemp(p^.right^.location.reference); }
+                            p^.location.loc:=LOC_FLAGS;
+                            p^.location.resflags:=F_C;
+                         end;
+                    end;
+                end;
+       end;
+{***}
+
+    procedure secondexpr(var p : ptree);
+
+      begin
+         secondpass(p^.left);
+      end;
+
+    procedure secondblockn(var p : ptree);
+
+      var
+         hp : ptree;
+
+      begin
+         hp:=p^.left;
+         while assigned(hp) do
+           begin
+              { assignments could be distance optimized }
+              if assigned(hp^.right) then
+                begin
+                   cleartempgen;
+                   secondpass(hp^.right);
+                end;
+              hp:=hp^.left;
+           end;
+      end;
+
+    procedure second_while_repeatn(var p : ptree);
+
+      var
+         l1,l2,l3,oldclabel,oldblabel : plabel;
+         otlabel,oflabel : plabel;
+
+      begin
+         getlabel(l1);
+         getlabel(l2);
+         { arrange continue and breaklabels: }
+         oldclabel:=aktcontinuelabel;
+         oldblabel:=aktbreaklabel;
+         if p^.treetype=repeatn then
+           begin
+              emitl(A_LABEL,l1);
+              aktcontinuelabel:=l1;
+              aktbreaklabel:=l2;
+              cleartempgen;
+              if assigned(p^.right) then
+                  secondpass(p^.right);
+
+              otlabel:=truelabel;
+              oflabel:=falselabel;
+              truelabel:=l2;
+              falselabel:=l1;
+              cleartempgen;
+              secondpass(p^.left);
+              maketojumpbool(p^.left);
+              emitl(A_LABEL,l2);
+              truelabel:=otlabel;
+              falselabel:=oflabel;
+           end
+         else
+           begin
+              { handling code at the end as it is much more efficient }
+              emitl(A_JMP,l2);
+
+              emitl(A_LABEL,l1);
+              cleartempgen;
+
+              getlabel(l3);
+              aktcontinuelabel:=l1;
+              aktbreaklabel:=l3;
+
+              if assigned(p^.right) then
+                secondpass(p^.right);
+
+              emitl(A_LABEL,l2);
+              otlabel:=truelabel;
+              oflabel:=falselabel;
+              truelabel:=l1;
+              falselabel:=l3;
+              cleartempgen;
+              secondpass(p^.left);
+              maketojumpbool(p^.left);
+
+              emitl(A_LABEL,l3);
+              truelabel:=otlabel;
+              falselabel:=oflabel;
+           end;
+         aktcontinuelabel:=oldclabel;
+         aktbreaklabel:=oldblabel;
+      end;
+
+    procedure secondifn(var p : ptree);
+
+      var
+         hl,otlabel,oflabel : plabel;
+
+      begin
+         otlabel:=truelabel;
+         oflabel:=falselabel;
+         getlabel(truelabel);
+         getlabel(falselabel);
+         cleartempgen;
+         secondpass(p^.left);
+         maketojumpbool(p^.left);
+         if assigned(p^.right) then
+           begin
+              emitl(A_LABEL,truelabel);
+              cleartempgen;
+              secondpass(p^.right);
+           end;
+         if assigned(p^.t1) then
+               begin
+              if assigned(p^.right) then
+                        begin
+                   getlabel(hl);
+                   emitl(A_JMP,hl);
+                end;
+              emitl(A_LABEL,falselabel);
+              cleartempgen;
+              secondpass(p^.t1);
+              if assigned(p^.right) then
+                emitl(A_LABEL,hl);
+           end
+         else
+           emitl(A_LABEL,falselabel);
+         if not(assigned(p^.right)) then
+           emitl(A_LABEL,truelabel);
+         truelabel:=otlabel;
+         falselabel:=oflabel;
+      end;
+
+    procedure secondbreakn(var p : ptree);
+
+      begin
+         if aktbreaklabel<>nil then
+           emitl(A_JMP,aktbreaklabel)
+         else
+           Message(cg_e_break_not_allowed);
+      end;
+
+    procedure secondcontinuen(var p : ptree);
+
+      begin
+         if aktcontinuelabel<>nil then
+           emitl(A_JMP,aktcontinuelabel)
+         else
+           Message(cg_e_continue_not_allowed);
+      end;
+
+    procedure secondfor(var p : ptree);
+
+      var
+         l3,oldclabel,oldblabel : plabel;
+         omitfirstcomp,temptovalue : boolean;
+         hs : byte;
+         temp1 : treference;
+         hop : tasmop;
+         cmpreg,cmp32 : tregister;
+         opsize : topsize;
+         count_var_is_signed : boolean;
+
+      begin
+         oldclabel:=aktcontinuelabel;
+         oldblabel:=aktbreaklabel;
+         getlabel(aktcontinuelabel);
+         getlabel(aktbreaklabel);
+         getlabel(l3);
+
+         { could we spare the first comparison ? }
+             omitfirstcomp:=false;
+         if p^.right^.treetype=ordconstn then
+           if p^.left^.right^.treetype=ordconstn then
+             omitfirstcomp:=(p^.backward and (p^.left^.right^.value>=p^.right^.value))
+               or (not(p^.backward) and (p^.left^.right^.value<=p^.right^.value));
+
+         { only calculate reference }
+         cleartempgen;
+         secondpass(p^.t2);
+         if not(simple_loadn) then
+          Message(cg_e_illegal_count_var);
+
+         { produce start assignment }
+         cleartempgen;
+         secondpass(p^.left);
+         count_var_is_signed:=is_signed(porddef(p^.t2^.resulttype));
+             hs:=p^.t2^.resulttype^.size;
+         cmp32:=getregister32;
+             case hs of
+            1 : begin
+                   opsize:=S_B;
+                   cmpreg:=reg32toreg8(cmp32);
+                end;
+            2 : begin
+                   opsize:=S_W;
+                   cmpreg:=reg32toreg16(cmp32);
+                end;
+            4 : begin
+                   opsize:=S_L;
+                   cmpreg:=cmp32;
+                end;
+         end;
+         cleartempgen;
+             secondpass(p^.right);
+         { calculate pointer value and check if changeable and if so }
+         { load into temporary variable                              }
+         if p^.right^.treetype<>ordconstn then
+           begin
+              temp1.symbol:=nil;
+              gettempofsizereference(hs,temp1);
+              temptovalue:=true;
+              if (p^.right^.location.loc=LOC_REGISTER) or
+                 (p^.right^.location.loc=LOC_CREGISTER) then
+                begin
+                   exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,p^.right^.location.register,
+                      newreference(temp1))));
+                 end
+              else
+                 concatcopy(p^.right^.location.reference,temp1,hs,false);
+           end
+         else temptovalue:=false;
+
+         if temptovalue then
+             begin
+              if p^.t2^.location.loc=LOC_CREGISTER then
+                begin
+                   exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1),
+                     p^.t2^.location.register)));
+                end
+              else
+                begin
+                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.t2^.location.reference),
+                     cmpreg)));
+                   exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1),
+                     cmpreg)));
+                end;
+           end
+         else
+             begin
+              if not(omitfirstcomp) then
+                begin
+                   if p^.t2^.location.loc=LOC_CREGISTER then
+                     exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^.right^.value,
+                       p^.t2^.location.register)))
+                   else
+                     exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,opsize,p^.right^.value,
+                 newreference(p^.t2^.location.reference))));
+                end;
+           end;
+         if p^.backward then
+           if count_var_is_signed then
+             hop:=A_JL
+           else hop:=A_JB
+         else
+           if count_var_is_signed then
+             hop:=A_JG
+            else hop:=A_JA;
+
+             if not(omitfirstcomp) or temptovalue then
+           emitl(hop,aktbreaklabel);
+
+         emitl(A_LABEL,l3);
+
+         { help register must not be in instruction block }
+         cleartempgen;
+         if assigned(p^.t1) then
+           secondpass(p^.t1);
+
+         emitl(A_LABEL,aktcontinuelabel);
+
+         { makes no problems there }
+         cleartempgen;
+
+         { demand help register again }
+         cmp32:=getregister32;
+         case hs of
+            1 : begin
+                   opsize:=S_B;
+                   cmpreg:=reg32toreg8(cmp32);
+                end;
+            2 : begin
+                   opsize:=S_W;
+                   cmpreg:=reg32toreg16(cmp32);
+                end;
+            4 : opsize:=S_L;
+         end;
+
+          { produce comparison and the corresponding }
+         { jump                                     }
+         if temptovalue then
+           begin
+              if p^.t2^.location.loc=LOC_CREGISTER then
+                begin
+                   exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1),
+                     p^.t2^.location.register)));
+                end
+              else
+                begin
+                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.t2^.location.reference),
+                     cmpreg)));
+                   exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1),
+                     cmpreg)));
+                    end;
+           end
+         else
+           begin
+              if p^.t2^.location.loc=LOC_CREGISTER then
+                exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^.right^.value,
+                  p^.t2^.location.register)))
+              else
+                 exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,opsize,p^.right^.value,
+                   newreference(p^.t2^.location.reference))));
+           end;
+         if p^.backward then
+           if count_var_is_signed then
+             hop:=A_JLE
+           else
+             hop :=A_JBE
+          else
+            if count_var_is_signed then
+              hop:=A_JGE
+            else
+                hop:=A_JAE;
+         emitl(hop,aktbreaklabel);
+         { according to count direction DEC or INC... }
+         { must be after the test because of 0to 255 for bytes !! }
+         if p^.backward then
+           hop:=A_DEC
+         else hop:=A_INC;
+
+         if p^.t2^.location.loc=LOC_CREGISTER then
+           exprasmlist^.concat(new(pai386,op_reg(hop,opsize,p^.t2^.location.register)))
+         else
+             exprasmlist^.concat(new(pai386,op_ref(hop,opsize,newreference(p^.t2^.location.reference))));
+         emitl(A_JMP,l3);
+
+           { this is the break label: }
+         emitl(A_LABEL,aktbreaklabel);
+         ungetregister32(cmp32);
+
+         if temptovalue then
+           ungetiftemp(temp1);
+
+         aktcontinuelabel:=oldclabel;
+         aktbreaklabel:=oldblabel;
+      end;
+
+{    var
+       hs : string; }
+
+    procedure secondexitn(var p : ptree);
+
+      var
+         is_mem : boolean;
+         {op : tasmop;
+         s : topsize;}
+         otlabel,oflabel : plabel;
+
+      label
+         do_jmp;
+
+      begin
+         if assigned(p^.left) then
+           begin
+              otlabel:=truelabel;
+              oflabel:=falselabel;
+              getlabel(truelabel);
+              getlabel(falselabel);
+              secondpass(p^.left);
+              case p^.left^.location.loc of
+                 LOC_FPU : goto do_jmp;
+                 LOC_MEM,LOC_REFERENCE : is_mem:=true;
+                 LOC_CREGISTER,
+                 LOC_REGISTER : is_mem:=false;
+                     LOC_FLAGS : begin
+                                exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_NO,R_AL)));
+                                        goto do_jmp;
+                             end;
+                 LOC_JUMP : begin
+                                      emitl(A_LABEL,truelabel);
+                               exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B,1,R_AL)));
+                               emitl(A_JMP,aktexit2label);
+                               exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B,R_AL,R_AL)));
+                               goto do_jmp;
+                            end;
+                 else internalerror(2001);
+              end;
+                 if (procinfo.retdef^.deftype=orddef) then
+                begin
+                   case porddef(procinfo.retdef)^.typ of
+                      s32bit,u32bit : if is_mem then
+                                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                                          newreference(p^.left^.location.reference),R_EAX)))
+                                      else
+                                        emit_reg_reg(A_MOV,S_L,
+                                          p^.left^.location.register,R_EAX);
+                           u8bit,s8bit,uchar,bool8bit : if is_mem then
+                                        exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_B,
+                                          newreference(p^.left^.location.reference),R_AL)))
+                                      else
+                                        emit_reg_reg(A_MOV,S_B,
+                                          p^.left^.location.register,R_AL);
+                      s16bit,u16bit : if is_mem then
+                                        exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W,
+                                          newreference(p^.left^.location.reference),R_AX)))
+                                      else
+                                        emit_reg_reg(A_MOV,S_W,
+                                                    p^.left^.location.register,R_AX);
+                   end;
+                end
+                  else
+                     if (procinfo.retdef^.deftype in
+                          [pointerdef,enumdef,procvardef]) then
+                       begin
+                           if is_mem then
+                              exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                                newreference(p^.left^.location.reference),R_EAX)))
+                           else
+                              exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,
+                                p^.left^.location.register,R_EAX)));
+                       end
+                 else
+                    if (procinfo.retdef^.deftype=floatdef) then
+                      begin
+                          if pfloatdef(procinfo.retdef)^.typ=f32bit then
+                            begin
+                                if is_mem then
+                                   exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
+                              newreference(p^.left^.location.reference),R_EAX)))
+                          else
+                            emit_reg_reg(A_MOV,S_L,
+                              p^.left^.location.register,R_EAX);
+                       end
+                     else
+                       if is_mem then
+                         floatload(pfloatdef(procinfo.retdef)^.typ,p^.left^.location.reference);
+                end;
+do_jmp:
+              truelabel:=otlabel;
+              falselabel:=oflabel;
+              emitl(A_JMP,aktexit2label);
+           end
+         else
+           begin
+              emitl(A_JMP,aktexitlabel);
+           end;
+       end;
+
+    procedure secondgoto(var p : ptree);
+
+       begin
+         emitl(A_JMP,p^.labelnr);
+       end;
+
+    procedure secondlabel(var p : ptree);
+
+      begin
+         emitl(A_LABEL,p^.labelnr);
+         cleartempgen;
+         secondpass(p^.left);
+      end;
+
+    procedure secondasm(var p : ptree);
+
+      begin
+         exprasmlist^.concatlist(p^.p_asm);
+       end;
+
+    procedure secondcase(var p : ptree);
+
+      var
+         with_sign : boolean;
+         opsize : topsize;
+         jmp_gt,jmp_le,jmp_lee : tasmop;
+         hp : ptree;
+         { register with case expression }
+         hregister : tregister;
+         endlabel,elselabel : plabel;
+
+         { true, if we can omit the range check of the jump table }
+         jumptable_no_range : boolean;
+
+      procedure gentreejmp(p : pcaserecord);
+
+        var
+           lesslabel,greaterlabel : plabel;
+
+       begin
+         emitl(A_LABEL,p^._at);
+         { calculate labels for left and right }
+         if (p^.less=nil) then
+           lesslabel:=elselabel
+         else
+           lesslabel:=p^.less^._at;
+         if (p^.greater=nil) then
+           greaterlabel:=elselabel
+         else
+           greaterlabel:=p^.greater^._at;
+           { calculate labels for left and right }
+         { no range label: }
+         if p^._low=p^._high then
+           begin
+              exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^._low,hregister)));
+              if greaterlabel=lesslabel then
+                begin
+                   emitl(A_JNE,lesslabel);
+                end
+              else
+                begin
+                   emitl(jmp_le,lesslabel);
+                   emitl(jmp_gt,greaterlabel);
+                end;
+              emitl(A_JMP,p^.statement);
+           end
+         else
+           begin
+              exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^._low,hregister)));
+              emitl(jmp_le,lesslabel);
+                exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^._high,hregister)));
+              emitl(jmp_gt,greaterlabel);
+              emitl(A_JMP,p^.statement);
+           end;
+          if assigned(p^.less) then
+           gentreejmp(p^.less);
+          if assigned(p^.greater) then
+           gentreejmp(p^.greater);
+      end;
+
+      procedure genlinearlist(hp : pcaserecord);
+
+        var
+           first : boolean;
+           last : longint;
+           {helplabel : longint;}
+
+        procedure genitem(t : pcaserecord);
+
+          begin
+             if assigned(t^.less) then
+               genitem(t^.less);
+             if t^._low=t^._high then
+               begin
+                  if t^._low-last=1 then
+                    exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize,hregister)))
+                  else if t^._low-last=0 then
+                    exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,opsize,hregister,hregister)))
+                  else
+                    exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,t^._low-last,hregister)));
+                  last:=t^._low;
+
+                  emitl(A_JZ,t^.statement);
+               end
+             else
+               begin
+                  { it begins with the smallest label, if the value }
+                  { is even smaller then jump immediately to the    }
+                  { ELSE-label                                      }
+                  if first then
+                    begin
+                       if t^._low-1=1 then
+                         exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize,
+                           hregister)))
+                       else if t^._low-1=0 then
+                         exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,opsize,
+                           hregister,hregister)))
+                       else
+                         exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,
+                           t^._low-1,hregister)));
+                       { work around: if the lower range=0 and we
+                         do the subtraction we have to take care
+                         of the sign!
+                       }
+                       if t^._low=0 then
+                         emitl(A_JLE,elselabel)
+                       else
+                         emitl(jmp_lee,elselabel);
+                    end
+                  { if there is no unused label between the last and the }
+                  { present label then the lower limit can be checked    }
+                  { immediately. else check the range in between:        }
+                  else if (t^._low-last>1)then
+                    begin
+                       if t^._low-last-1=1 then
+                         exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize,hregister)))
+                       else
+                         exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,t^._low-last-1,hregister)));
+                       emitl(jmp_lee,elselabel);
+                    end;
+                  exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,t^._high-t^._low+1,hregister)));
+                  emitl(jmp_lee,t^.statement);
+
+                  last:=t^._high;
+               end;
+             first:=false;
+             if assigned(t^.greater) then
+               genitem(t^.greater);
+          end;
+
+        var
+           hr : tregister;
+
+          begin
+             { case register is modified by the list evalution }
+           if (p^.left^.location.loc=LOC_CREGISTER) then
+             begin
+                hr:=getregister32;
+                case opsize of
+                   S_B : hregister:=reg32toreg8(hr);
+                   S_W : hregister:=reg32toreg16(hr);
+                   S_L : hregister:=hr;
+                end;
+             end;
+           last:=0;
+           first:=true;
+           genitem(hp);
+           emitl(A_JMP,elselabel);
+        end;
+
+      procedure genjumptable(hp : pcaserecord;min_,max_ : longint);
+
+        var
+           table : plabel;
+           last : longint;
+           hr : preference;
+
+        procedure genitem(t : pcaserecord);
+
+          var
+             i : longint;
+
+          begin
+             if assigned(t^.less) then
+               genitem(t^.less);
+             { fill possible hole }
+             for i:=last+1 to t^._low-1 do
+               datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
+                 (elselabel)))));
+             for i:=t^._low to t^._high do
+               datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
+                    (t^.statement)))));
+              last:=t^._high;
+             if assigned(t^.greater) then
+               genitem(t^.greater);
+            end;
+
+          begin
+           if not(jumptable_no_range) then
+             begin
+                exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,min_,hregister)));
+                { case expr less than min_ => goto elselabel }
+                emitl(jmp_le,elselabel);
+                exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,max_,hregister)));
+                emitl(jmp_gt,elselabel);
+             end;
+           getlabel(table);
+           { extend with sign }
+           if opsize=S_W then
+             begin
+                exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,hregister,
+                  reg16toreg32(hregister))));
+                hregister:=reg16toreg32(hregister);
+             end
+           else if opsize=S_B then
+             begin
+                exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,hregister,
+                  reg8toreg32(hregister))));
+                hregister:=reg8toreg32(hregister);
+             end;
+           new(hr);
+           reset_reference(hr^);
+           hr^.symbol:=stringdup(lab2str(table));
+           hr^.offset:=(-min_)*4;
+           hr^.index:=hregister;
+           hr^.scalefactor:=4;
+           exprasmlist^.concat(new(pai386,op_ref(A_JMP,S_NO,hr)));
+           { !!!!! generate tables
+             if not(cs_littlesize in aktswitches^ ) then
+             datasegment^.concat(new(pai386,op_const(A_ALIGN,S_NO,4)));
+           }
+           datasegment^.concat(new(pai_label,init(table)));
+             last:=min_;
+           genitem(hp);
+             { !!!!!!!
+           if not(cs_littlesize in aktswitches^ ) then
+             exprasmlist^.concat(new(pai386,op_const(A_ALIGN,S_NO,4)));
+           }
+        end;
+
+      var
+         lv,hv,min_label,max_label,labels : longint;
+         max_linear_list : longint;
+
+      begin
+         getlabel(endlabel);
+         getlabel(elselabel);
+         with_sign:=is_signed(p^.left^.resulttype);
+         if with_sign then
+           begin
+              jmp_gt:=A_JG;
+              jmp_le:=A_JL;
+              jmp_lee:=A_JLE;
+           end
+         else
+            begin
+              jmp_gt:=A_JA;
+              jmp_le:=A_JB;
+              jmp_lee:=A_JBE;
+           end;
+         cleartempgen;
+         secondpass(p^.left);
+         { determines the size of the operand }
+         { determines the size of the operand }
+         opsize:=bytes2Sxx[p^.left^.resulttype^.size];
+         { copy the case expression to a register }
+         { copy the case expression to a register }
+         case p^.left^.location.loc of
+            LOC_REGISTER,
+            LOC_CREGISTER:
+              hregister:=p^.left^.location.register;
+            LOC_MEM,LOC_REFERENCE : begin
+                                       del_reference(p^.left^.location.reference);
+                                           hregister:=getregister32;
+                                       case opsize of
+                                          S_B : hregister:=reg32toreg8(hregister);
+                                          S_W : hregister:=reg32toreg16(hregister);
+                                       end;
+                                       exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(
+                                         p^.left^.location.reference),hregister)));
+                                    end;
+            else internalerror(2002);
+         end;
+         { now generate the jumps }
+           if cs_optimize in aktswitches then
+           begin
+              { procedures are empirically passed on }
+              { consumption can also be calculated   }
+              { but does it pay on the different     }
+              { processors?                          }
+              { moreover can the size only be appro- }
+              { ximated as it is not known if rel8,  }
+              { rel16 or rel32 jumps are used        }
+              min_label:=case_get_min(p^.nodes);
+              max_label:=case_get_max(p^.nodes);
+              labels:=case_count_labels(p^.nodes);
+              { can we omit the range check of the jump table }
+              getrange(p^.left^.resulttype,lv,hv);
+              jumptable_no_range:=(lv=min_label) and (hv=max_label);
+
+              { optimize for size ? }
+              if cs_littlesize in aktswitches  then
+                begin
+                   if (labels<=2) or ((max_label-min_label)>3*labels) then
+                  { a linear list is always smaller than a jump tree }
+                     genlinearlist(p^.nodes)
+                   else
+                          { if the labels less or more a continuum then }
+                          genjumptable(p^.nodes,min_label,max_label);
+                end
+              else
+                begin
+                   if jumptable_no_range then
+                     max_linear_list:=4
+                   else
+                     max_linear_list:=2;
+                   { a jump table crashes the pipeline! }
+                   if opt_processors=i486 then
+                     inc(max_linear_list,3);
+                       if opt_processors=pentium then
+                     inc(max_linear_list,6);
+                   if opt_processors=pentiumpro then
+                     inc(max_linear_list,9);
+
+                   if (labels<=max_linear_list) then
+                     genlinearlist(p^.nodes)
+                   else
+                     begin
+                        if ((max_label-min_label)>4*labels) then
+                          begin
+                             if labels>16 then
+                               gentreejmp(p^.nodes)
+                             else
+                               genlinearlist(p^.nodes);
+                          end
+                        else
+                          genjumptable(p^.nodes,min_label,max_label);
+                     end;
+                end;
+             end
+           else
+           { it's always not bad }
+           genlinearlist(p^.nodes);
+
+         { now generate the instructions }
+           hp:=p^.right;
+         while assigned(hp) do
+           begin
+              cleartempgen;
+              secondpass(hp^.right);
+              emitl(A_JMP,endlabel);
+              hp:=hp^.left;
+           end;
+         emitl(A_LABEL,elselabel);
+         { ...and the else block }
+         if assigned(p^.elseblock) then
+             begin
+              cleartempgen;
+              secondpass(p^.elseblock);
+           end;
+         emitl(A_LABEL,endlabel);
+      end;
+
+    { generates the code for a raise statement }
+    procedure secondraise(var p : ptree);
+
+      var
+         a : plabel;
+
+      begin
+         if assigned(p^.left) then
+           begin
+              { generate the address }
+              if assigned(p^.right) then
+                begin
+                   secondpass(p^.right);
+                       if codegenerror then
+                          exit;
+                end
+              else
+                        begin
+                   getlabel(a);
+                           emitl(A_LABEL,a);
+                   exprasmlist^.concat(new(pai386,
+                     op_csymbol(A_PUSH,S_L,newcsymbol(lab2str(a),0))));
+                end;
+              secondpass(p^.left);
+              if codegenerror then
+                exit;
+
+              case p^.left^.location.loc of
+                 LOC_MEM,LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference);
+                 LOC_CREGISTER,LOC_REGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,
+                       p^.left^.location.register)));
+                 else Message(sym_e_type_mismatch);
+              end;
+                 emitcall('DO_RAISE',true);
+             end
+           else
+             emitcall('DO_RERAISE',true);
+       end;
+
+     procedure secondtryexcept(var p : ptree);
+
+      begin
+      end;
+
+    procedure secondtryfinally(var p : ptree);
+
+      begin
+      end;
+
+     procedure secondfail(var p : ptree);
+
+      var hp : preference;
+
+      begin
+         {if procinfo.exceptions then
+           aktproccode.concat(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_E'))
+         else }
+         { we should know if the constructor is called with a new or not,
+         how can we do that ???
+         exprasmlist^.concat(new(pai386,op_csymbol(A_CALL,S_NO,newcsymbol('HELP_DESTRUCTOR',0))));
+         }
+         exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_ESI,R_ESI)));
+         { also reset to zero in the stack }
+         new(hp);
+         reset_reference(hp^);
+         hp^.offset:=procinfo.ESI_offset;
+         hp^.base:=procinfo.framepointer;
+         exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_ESI,hp)));
+         exprasmlist^.concat(new(pai_labeled,init(A_JMP,quickexitlabel)));
+      end;
+
+     procedure secondwith(var p : ptree);
+
+        var
+            ref : treference;
+          symtable : psymtable;
+          i : longint;
+
+      begin
+         if assigned(p^.left) then
+            begin
+               secondpass(p^.left);
+               ref.symbol:=nil;
+               gettempofsizereference(4,ref);
+               exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
+                 newreference(p^.left^.location.reference),R_EDI)));
+               exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
+                 R_EDI,newreference(ref))));
+               del_reference(p^.left^.location.reference);
+               { the offset relative to (%ebp) is only needed here! }
+               symtable:=p^.withsymtable;
+               for i:=1 to p^.tablecount do
+                 begin
+                    symtable^.datasize:=ref.offset;
+                    symtable:=symtable^.next;
+                 end;
+
+               { p^.right can be optimize out !!! }
+               if p^.right<>nil then
+                 secondpass(p^.right);
+               { clear some stuff }
+               ungetiftemp(ref);
+            end;
+       end;
+
+     procedure secondpass(var p : ptree);
+
+       const
+           procedures : array[ttreetyp] of secondpassproc =
+               (secondadd,secondadd,secondadd,secondmoddiv,secondadd,
+                secondmoddiv,secondassignment,secondload,secondnothing,
+                secondadd,secondadd,secondadd,secondadd,
+                secondadd,secondadd,secondin,secondadd,
+                secondadd,secondshlshr,secondshlshr,secondadd,
+               secondadd,secondsubscriptn,secondderef,secondaddr,
+             seconddoubleaddr,
+             secondordconst,secondtypeconv,secondcalln,secondnothing,
+             secondrealconst,secondfixconst,secondumminus,
+             secondasm,secondvecn,
+             secondstringconst,secondfuncret,secondselfn,
+             secondnot,secondinline,secondniln,seconderror,
+             secondnothing,secondhnewn,secondhdisposen,secondnewn,
+             secondsimplenewdispose,secondnothing,secondsetcons,secondblockn,
+             secondnothing,secondnothing,secondifn,secondbreakn,
+             secondcontinuen,second_while_repeatn,second_while_repeatn,secondfor,
+             secondexitn,secondwith,secondcase,secondlabel,
+             secondgoto,secondsimplenewdispose,secondtryexcept,secondraise,
+             secondnothing,secondtryfinally,secondis,secondas,seconderror,
+             secondfail,
+             secondnothing,secondloadvmt);
+      var
+         oldcodegenerror : boolean;
+         oldswitches : Tcswitches;
+         oldis : pinputfile;
+         oldnr : longint;
+
+      begin
+         oldcodegenerror:=codegenerror;
+         oldswitches:=aktswitches;
+           oldis:=current_module^.current_inputfile;
+            oldnr:=current_module^.current_inputfile^.line_no;
+
+         codegenerror:=false;
+           current_module^.current_inputfile:=p^.inputfile;
+         current_module^.current_inputfile^.line_no:=p^.line;
+         aktswitches:=p^.pragmas;
+         if not(p^.error) then
+           begin
+              procedures[p^.treetype](p);
+              p^.error:=codegenerror;
+                 codegenerror:=codegenerror or oldcodegenerror;
+           end
+         else codegenerror:=true;
+         aktswitches:=oldswitches;
+           current_module^.current_inputfile:=oldis;
+         current_module^.current_inputfile^.line_no:=oldnr;
+      end;
+
+    function do_secondpass(var p : ptree) : boolean;
+
+      begin
+         codegenerror:=false;
+         if not(p^.error) then
+           secondpass(p);
+         do_secondpass:=codegenerror;
+      end;
+
+    var
+       regvars : array[1..maxvarregs] of pvarsym;
+       regvars_para : array[1..maxvarregs] of boolean;
+       regvars_refs : array[1..maxvarregs] of longint;
+       parasym : boolean;
+
+    procedure searchregvars(p : psym);
+
+      var
+         i,j,k : longint;
+
+      begin
+         if (p^.typ=varsym) and (pvarsym(p)^.regable) then
+           begin
+              { walk through all momentary register variables }
+              for i:=1 to maxvarregs do
+                begin
+                   { free register ? }
+                   if regvars[i]=nil then
+                     begin
+                        regvars[i]:=pvarsym(p);
+                        regvars_para[i]:=parasym;
+                        break;
+                     end;
+                   { else throw out a variable ? }
+                       j:=pvarsym(p)^.refs;
+                   { parameter get a less value }
+                   if parasym then
+                     begin
+                        if cs_littlesize in aktswitches  then
+                          dec(j,1)
+                        else
+                          dec(j,100);
+                     end;
+                   if (j>regvars_refs[i]) and (j>0) then
+                     begin
+                        for k:=maxvarregs-1 downto i do
+                          begin
+                             regvars[k+1]:=regvars[k];
+                             regvars_para[k+1]:=regvars_para[k];
+                          end;
+                        { calc the new refs
+                        pvarsym(p)^.refs:=j; }
+                        regvars[i]:=pvarsym(p);
+                        regvars_para[i]:=parasym;
+                        regvars_refs[i]:=j;
+                        break;
+                     end;
+                end;
+           end;
+      end;
+
+    procedure generatecode(var p : ptree);
+
+      var
+           { *pass modifies with every node aktlinenr and current_module^.current_inputfile, }
+         { to constantly contain the right line numbers             }
+           oldis : pinputfile;
+         oldnr,i : longint;
+         regsize : topsize;
+         regi : tregister;
+          hr : preference;
+
+       label
+         nextreg;
+
+      begin
+         cleartempgen;
+         oldis:=current_module^.current_inputfile;
+         oldnr:=current_module^.current_inputfile^.line_no;
+         { when size optimization only count occurrence }
+         if cs_littlesize in aktswitches then
+           t_times:=1
+         else
+           { reference for repetition is 100 }
+           t_times:=100;
+         { clear register count }
+{$ifdef SUPPORT_MMX}
+         for regi:=R_EAX to R_MM6 do
+           begin
+              reg_pushes[regi]:=0;
+              is_reg_var[regi]:=false;
+           end;
+{$else SUPPORT_MMX}
+         for regi:=R_EAX to R_EDI do
+           begin
+              reg_pushes[regi]:=0;
+              is_reg_var[regi]:=false;
+           end;
+{$endif SUPPORT_MMX}
+         use_esp_stackframe:=false;
+
+         if not(do_firstpass(p)) then
+           begin
+              { max. optimizations     }
+              { only if no asm is used }
+              if (cs_maxoptimieren in aktswitches) and
+                ((procinfo.flags and pi_uses_asm)=0) then
+                begin
+                   { can we omit the stack frame ? }
+                   { conditions:
+                     1. procedure (not main block)
+                     2. no constructor or destructor
+                     3. no call to other procedures
+                     4. no interrupt handler
+                   }
+                   if assigned(aktprocsym) then
+                     begin
+                       if (aktprocsym^.definition^.options and
+                        poconstructor+podestructor+poinline+pointerrupt=0) and
+                        ((procinfo.flags and pi_do_call)=0) and (lexlevel>1) then
+                       begin
+                         { use ESP as frame pointer }
+                         procinfo.framepointer:=R_ESP;
+                         use_esp_stackframe:=true;
+
+                         { calc parameter distance new }
+                         dec(procinfo.framepointer_offset,4);
+                         dec(procinfo.ESI_offset,4);
+
+                         dec(procinfo.retoffset,4);
+
+                         dec(procinfo.call_offset,4);
+                         aktprocsym^.definition^.parast^.call_offset:=procinfo.call_offset;
+                       end;
+                     end;
+                   if (p^.registers32<4) then
+                       begin
+                        for i:=1 to maxvarregs do
+                          regvars[i]:=nil;
+                        parasym:=false;
+{$ifdef tp}
+                        symtablestack^.foreach(searchregvars);
+{$else}
+                        symtablestack^.foreach(@searchregvars);
+{$endif}
+                        { copy parameter into a register ? }
+                        parasym:=true;
+{$ifdef tp}
+                        symtablestack^.next^.foreach(searchregvars);
+{$else}
+                        symtablestack^.next^.foreach(@searchregvars);
+{$endif}
+
+                        { hold needed registers free }
+                        for i:=maxvarregs downto maxvarregs-p^.registers32+1 do
+                          regvars[i]:=nil;
+                        { now assign register }
+                        for i:=1 to maxvarregs-p^.registers32 do
+                          begin
+                             if assigned(regvars[i]) then
+                               begin
+                                  { it is nonsens, to copy the variable to }
+                                  { a register because we need then much   }
+                                  { pushes ?                               }
+                                  if reg_pushes[varregs[i]]>=regvars[i]^.refs then
+                                    begin
+                                       regvars[i]:=nil;
+                                       goto nextreg;
+                                    end;
+
+                                  { register is no longer available for }
+                                  { expressions                         }
+                                  { search the register which is the most }
+                                  { unused                                }
+                                  usableregs:=usableregs-[varregs[i]];
+                                  is_reg_var[varregs[i]]:=true;
+                                  dec(c_usableregs);
+
+                                  { possibly no 32 bit register are needed }
+                                  if  (regvars[i]^.definition^.deftype=orddef) and
+                                      (
+                                       (porddef(regvars[i]^.definition)^.typ=bool8bit) or
+                                       (porddef(regvars[i]^.definition)^.typ=uchar) or
+                                       (porddef(regvars[i]^.definition)^.typ=u8bit) or
+                                       (porddef(regvars[i]^.definition)^.typ=s8bit)
+                                      ) then
+                                    begin
+                                       regvars[i]^.reg:=reg32toreg8(varregs[i]);
+                                       regsize:=S_B;
+                                    end
+                                  else if  (regvars[i]^.definition^.deftype=orddef) and
+                                      (
+                                       (porddef(regvars[i]^.definition)^.typ=u16bit) or
+                                       (porddef(regvars[i]^.definition)^.typ=s16bit)
+                                      ) then
+                                    begin
+                                       regvars[i]^.reg:=reg32toreg16(varregs[i]);
+                                       regsize:=S_W;
+                                    end
+                                  else
+                                    begin
+                                       regvars[i]^.reg:=varregs[i];
+                                       regsize:=S_L;
+                                    end;
+                                  { parameter must be load }
+                                  if regvars_para[i] then
+                                    begin
+                                       { procinfo is there actual,      }
+                                       { because we can't never be in a }
+                                       { nested procedure               }
+                                       { when loading parameter to reg  }
+                                       new(hr);
+                                       reset_reference(hr^);
+                                       hr^.offset:=pvarsym(regvars[i])^.address+procinfo.call_offset;
+                                       hr^.base:=procinfo.framepointer;
+                                       procinfo.aktentrycode^.concat(new(pai386,op_ref_reg(A_MOV,regsize,
+                                         hr,regvars[i]^.reg)));
+                                       unused:=unused - [regvars[i]^.reg];
+                                    end;
+                                  { procedure uses this register }
+                                  usedinproc:=usedinproc or ($80 shr byte(varregs[i]));
+                               end;
+                             nextreg:
+                               { dummy }
+                               regsize:=S_W;
+                          end;
+                        if (verbosity and v_debug)=v_debug then
+                          begin
+                             for i:=1 to maxvarregs do
+                               begin
+                                  if assigned(regvars[i]) then
+                                   Message3(cg_d_register_weight,reg2str(regvars[i]^.reg),
+                                           tostr(regvars[i]^.refs),regvars[i]^.name);
+                               end;
+                          end;
+                     end;
+                end;
+              do_secondpass(p);
+
+              { all registers can be used again }
+              usableregs:=[R_EAX,R_EBX,R_ECX,R_EDX];
+{$ifdef SUPPORT_MMX}
+              usableregs:=usableregs+[R_MM0..R_MM6];
+{$endif SUPPORT_MMX}
+              c_usableregs:=4;
+           end;
+         procinfo.aktproccode^.concatlist(exprasmlist);
+
+         current_module^.current_inputfile:=oldis;
+         current_module^.current_inputfile^.line_no:=oldnr;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:13  root
+  Initial revision
+
+  Revision 1.58  1998/03/24 21:48:30  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.57  1998/03/16 22:42:19  florian
+    * some fixes of Peter applied:
+      ofs problem, profiler support
+
+  Revision 1.56  1998/03/13 22:45:57  florian
+    * small bug fixes applied
+
+  Revision 1.55  1998/03/11 22:22:51  florian
+    * Fixed circular unit uses, when the units are not in the current dir (from Peter)
+    * -i shows correct info, not <lf> anymore (from Peter)
+    * linking with shared libs works again (from Peter)
+
+  Revision 1.54  1998/03/10 23:48:35  florian
+    * a couple of bug fixes to get the compiler with -OGaxz compiler, sadly
+      enough, it doesn't run
+
+  Revision 1.53  1998/03/10 16:27:37  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.52  1998/03/10 01:17:16  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.51  1998/03/09 10:44:37  peter
+    + string='', string<>'', string:='', string:=char optimizes (the first 2
+      were already in cg68k2)
+
+  Revision 1.50  1998/03/06 00:52:10  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.49  1998/03/04 01:34:56  peter
+    * messages for unit-handling and assembler/linker
+    * the compiler compiles without -dGDB, but doesn't work yet
+    + -vh for Hint
+
+  Revision 1.48  1998/03/03 20:36:51  florian
+    * bug in second_smaller fixed
+
+  Revision 1.47  1998/03/03 01:08:24  florian
+    * bug0105 and bug0106 problem solved
+
+  Revision 1.46  1998/03/02 01:48:24  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.45  1998/03/01 22:46:06  florian
+    + some win95 linking stuff
+    * a couple of bugs fixed:
+      bug0055,bug0058,bug0059,bug0064,bug0072,bug0093,bug0095,bug0098
+
+  Revision 1.44  1998/02/24 16:49:57  peter
+    * stackframe ommiting generated 'ret $-4'
+    + timer.pp bp7 version
+    * innr.inc are now the same files
+
+  Revision 1.43  1998/02/22 23:03:12  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.42  1998/02/21 04:09:13  carl
+    * stupid syntax error fix
+
+  Revision 1.41  1998/02/20 20:35:14  carl
+    * Fixed entry and exit code which was ALL messed up
+
+  Revision 1.40  1998/02/19 12:15:08  daniel
+  * Optimized a statement that did pain to my eyes.
+
+  Revision 1.39  1998/02/17 21:20:40  peter
+    + Script unit
+    + __EXIT is called again to exit a program
+    - target_info.link/assembler calls
+    * linking works again for dos
+    * optimized a few filehandling functions
+    * fixed stabs generation for procedures
+
+  Revision 1.38  1998/02/15 21:16:12  peter
+    * all assembler outputs supported by assemblerobject
+    * cleanup with assembleroutputs, better .ascii generation
+    * help_constructor/destructor are now added to the externals
+    - generation of asmresponse is not outputformat depended
+
+  Revision 1.37  1998/02/14 01:45:15  peter
+    * more fixes
+    - pmode target is removed
+    - search_as_ld is removed, this is done in the link.pas/assemble.pas
+    + findexe() to search for an executable (linker,assembler,binder)
+
+  Revision 1.36  1998/02/13 22:26:19  peter
+    * fixed a few SigSegv's
+    * INIT$$ was not written for linux!
+    * assembling and linking works again for linux and dos
+    + assembler object, only attasmi3 supported yet
+    * restore pp.pas with AddPath etc.
+
+  Revision 1.35  1998/02/13 10:34:50  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.34  1998/02/12 17:18:57  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.33  1998/02/12 11:49:56  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.23  1998/02/01 19:39:50  florian
+    * clean up
+    * bug0029 fixed
+
+  Revision 1.22  1998/01/27 22:02:29  florian
+    * small bug fix to the compiler work, I forgot a not(...):(
+
+  Revision 1.21  1998/01/27 10:49:15  florian
+  *** empty log message ***
+
+  Revision 1.20  1998/01/26 17:29:14  florian
+    * Peter's fix for bug0046 applied
+
+  Revision 1.19  1998/01/25 22:28:55  florian
+    * a lot bug fixes on the DOM
+
+  Revision 1.18  1998/01/21 21:29:50  florian
+    * some fixes for Delphi classes
+
+  Revision 1.17  1998/01/20 23:53:04  carl
+    * bugfix 74 (FINAL, the one from Pierre was incomplete under BP)
+
+  Revision 1.16  1998/01/19 10:25:14  pierre
+    * bug in object function call in main program or unit init fixed
+
+  Revision 1.15  1998/01/16 22:34:29  michael
+  * Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
+    in this compiler :)
+
+  Revision 1.14  1998/01/16 18:03:11  florian
+    * small bug fixes, some stuff of delphi styled constructores added
+
+  Revision 1.13  1998/01/13 23:11:05  florian
+    + class methods
+
+  Revision 1.12  1998/01/07 00:16:44  michael
+  Restored released version (plus fixes) as current
+
+  Revision 1.10  1997/12/13 18:59:42  florian
+  + I/O streams are now also declared as external, if neccessary
+  * -Aobj generates now a correct obj file via nasm
+
+  Revision 1.9  1997/12/10 23:07:16  florian
+  * bugs fixed: 12,38 (also m68k),39,40,41
+  + warning if a system unit is without -Us compiled
+  + warning if a method is virtual and private (was an error)
+  * some indentions changed
+  + factor does a better error recovering (omit some crashes)
+  + problem with @type(x) removed (crashed the compiler)
+
+  Revision 1.8  1997/12/09 13:35:47  carl
+  + renamed pai_labeled386 to pai_labeled
+  + renamed S_T to S_X
+
+  Revision 1.7  1997/12/04 10:39:11  pierre
+    + secondadd separated in file cgi386ad.inc
+
+  Revision 1.5  1997/11/29 15:41:45  florian
+  only small changes
+
+  Revision 1.3  1997/11/28 15:43:15  florian
+  Fixed stack ajustment bug, 0.9.8 compiles now 0.9.8 without problems.
+
+  Revision 1.2  1997/11/28 14:26:19  florian
+  Fixed some bugs
+
+  Revision 1.1.1.1  1997/11/27 08:32:54  michael
+  FPC Compiler CVS start
+
+
+  Pre-CVS log:
+
+  FK     Florian Klaempfl
+  PM     Pierre Muller
+  +      feature added
+  -      removed
+  *      bug fixed or changed
+
+  History (started with version 0.9.0):
+      23th october 1996:
+           + some emit calls replaced (FK)
+      24th october 1996:
+         * for bug fixed (FK)
+      26th october 1996:
+         * english comments (FK)
+       5th november 1996:
+         * new init and terminate code (FK)
+
+      ...... some items missed
+
+      19th september 1997:
+         * a call to a function procedure a;[ C ]; doesn't crash the stack
+           furthermore (FK)
+         * bug in var_reg assignment fixed
+           did not keep p^.register32 registers free ! (PM)
+      22th september 1997:
+         * stack layout for nested procedures in methods modified:
+           ESI is no more pushed (must be loaded via framepointer) (FK)
+      24th september 1997:
+         + strings constants in consts list to check for existing strings (PM)
+      24th september 1997:
+         * constructor bug removed (FK)
+         * source splitted (into cgi386 and cgi3862 for FPC) (FK)
+         * line_no and inputfile are now in secondpass saved (FK)
+         * patching error removed (the switch -Ox was always used
+           because of a misplaced end) (FK)
+         + strings constants in consts list to check for existing strings (PM)
+      25th september 1997:
+         + secondload provides now the informations for open arrays (FK)
+         + support of high for open arrays (FK)
+         + the high parameter is now pushed for open arrays (FK)
+      3th october 1997:
+         + function second_bool_to_byte for ord(boolean) (PM)
+      4th october 1997:
+         + code for in_pred_x in_succ_x no bound check (PM)
+      13th october 1997:
+         + added code for static modifier for objects variables and methods (PM)
+      14th october 1997:
+         + second_bool_to_byte handles now also LOC_JUMP (FK)
+      28th october 1997:
+         * in secondcallparan bug with param from read/write while nil defcoll^.data
+           fixed (PM)
+      3rd november 1997:
+         + added code for symdif for sets (PM)
+      28th october 1997:
+         * in secondcallparan bug with param from read/write while nil defcoll^.data
+           fixed (PM)
+      3rd november 1997:
+         + added code for symdif for sets (PM)
+      12th november 1997:
+         + added text write for boolean (PM)
+         * bug in secondcallparan for LOC_FPU (assumed that the type was double) (PM)
+      13th november 1997:
+         + added partial code for u32bit support (PM)
+      22th november 1997:
+         * bug in stack alignment found (PM)
+
+}

compiler/cgi3862.pas

@@ -0,0 +1,59 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl
+
+    This unit generates i386 (or better) assembler from the parse tree
+
+    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.
+
+ ****************************************************************************
+}
+{$ifdef tp}
+  {$E+,F+,N+,D+,L+,Y+}
+{$endif}
+unit cgi3862;
+
+  interface
+
+    uses
+       objects,verbose,cobjects,systems,globals,tree,
+       symtable,types,strings,pass_1,hcodegen,
+       aasm,i386,tgeni386,files,cgai386;
+
+    procedure secondadd(var p : ptree);
+    procedure secondaddstring(var p : ptree);
+    procedure secondas(var p : ptree);
+    procedure secondis(var p : ptree);
+    procedure secondloadvmt(var p : ptree);
+
+  implementation
+
+    uses
+       cgi386;
+
+{$I cgi386ad.inc}
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:12  root
+  Initial revision
+
+  Revision 1.9  1998/03/10 01:17:18  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+}

compiler/cgi386ad.inc

@@ -0,0 +1,1251 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl
+
+    This include file generates i386+ assembler from the parse tree
+
+    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.
+
+ ****************************************************************************
+}
+
+    procedure secondas(var p : ptree);
+
+      var
+         pushed : tpushed;
+
+      begin
+         secondpass(p^.left);
+         { save all used registers }
+         pushusedregisters(pushed,$ff);
+
+         { push instance to check: }
+         case p^.left^.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              exprasmlist^.concat(new(pai386,op_reg(A_PUSH,
+                S_L,p^.left^.location.register)));
+            LOC_MEM,LOC_REFERENCE:
+              exprasmlist^.concat(new(pai386,op_ref(A_PUSH,
+                S_L,newreference(p^.left^.location.reference))));
+            else internalerror(100);
+         end;
+
+         { we doesn't modifiy the left side, we check only the type }
+         set_location(p^.location,p^.left^.location);
+
+         { generate type checking }
+         secondpass(p^.right);
+         case p^.right^.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              begin
+                 exprasmlist^.concat(new(pai386,op_reg(A_PUSH,
+                   S_L,p^.right^.location.register)));
+                 ungetregister32(p^.right^.location.register);
+              end;
+            LOC_MEM,LOC_REFERENCE:
+              begin
+                 exprasmlist^.concat(new(pai386,op_ref(A_PUSH,
+                   S_L,newreference(p^.right^.location.reference))));
+                 del_reference(p^.right^.location.reference);
+              end;
+            else internalerror(100);
+         end;
+         emitcall('DO_AS',true);
+         { restore register, this restores automatically the }
+         { result                                            }
+         popusedregisters(pushed);
+      end;
+
+    procedure secondloadvmt(var p : ptree);
+
+      begin
+         p^.location.register:=getregister32;
+         exprasmlist^.concat(new(pai386,op_csymbol_reg(A_MOV,
+            S_L,newcsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname,0),
+            p^.location.register)));
+      end;
+
+    procedure secondis(var p : ptree);
+
+      var
+         pushed : tpushed;
+
+      begin
+         { save all used registers }
+         pushusedregisters(pushed,$ff);
+         secondpass(p^.left);
+         p^.location.loc:=LOC_FLAGS;
+         p^.location.resflags:=F_NE;
+
+         { push instance to check: }
+         case p^.left^.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              begin
+                 exprasmlist^.concat(new(pai386,op_reg(A_PUSH,
+                   S_L,p^.left^.location.register)));
+                 ungetregister32(p^.left^.location.register);
+              end;
+            LOC_MEM,LOC_REFERENCE:
+              begin
+                 exprasmlist^.concat(new(pai386,op_ref(A_PUSH,
+                   S_L,newreference(p^.left^.location.reference))));
+                 del_reference(p^.left^.location.reference);
+              end;
+            else internalerror(100);
+         end;
+
+         { generate type checking }
+         secondpass(p^.right);
+         case p^.right^.location.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              begin
+                 exprasmlist^.concat(new(pai386,op_reg(A_PUSH,
+                   S_L,p^.right^.location.register)));
+                 ungetregister32(p^.right^.location.register);
+              end;
+            LOC_MEM,LOC_REFERENCE:
+              begin
+                 exprasmlist^.concat(new(pai386,op_ref(A_PUSH,
+                   S_L,newreference(p^.right^.location.reference))));
+                 del_reference(p^.right^.location.reference);
+              end;
+            else internalerror(100);
+         end;
+         emitcall('DO_IS',true);
+         exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_B,R_AL,R_AL)));
+         popusedregisters(pushed);
+      end;
+
+    procedure setaddresult(cmpop,unsigned : boolean;var p :ptree);
+      var
+         flags : tresflags;
+      begin
+         if (p^.left^.resulttype^.deftype<>stringdef) and
+            not ((p^.left^.resulttype^.deftype=setdef) and
+               (psetdef(p^.left^.resulttype)^.settype<>smallset)) then
+           begin
+              { this can be useful if for instance length(string) is called }
+              if (p^.left^.location.loc=LOC_REFERENCE) or
+                 (p^.left^.location.loc=LOC_MEM) then
+                ungetiftemp(p^.left^.location.reference);
+              if (p^.right^.location.loc=LOC_REFERENCE) or
+                 (p^.right^.location.loc=LOC_MEM) then
+                ungetiftemp(p^.right^.location.reference);
+           end;
+         { in case of comparison operation the put result in the flags }
+         if cmpop then
+           begin
+              if not(unsigned) then
+                begin
+                   if p^.swaped then
+                     case p^.treetype of
+                        equaln : flags:=F_E;
+                        unequaln : flags:=F_NE;
+                        ltn : flags:=F_G;
+                        lten : flags:=F_GE;
+                        gtn : flags:=F_L;
+                        gten : flags:=F_LE;
+                     end
+                   else
+                     case p^.treetype of
+                        equaln : flags:=F_E;
+                        unequaln : flags:=F_NE;
+                        ltn : flags:=F_L;
+                        lten : flags:=F_LE;
+                        gtn : flags:=F_G;
+                        gten : flags:=F_GE;
+                     end;
+                end
+              else
+                begin
+                   if p^.swaped then
+                     case p^.treetype of
+                        equaln : flags:=F_E;
+                        unequaln : flags:=F_NE;
+                        ltn : flags:=F_A;
+                        lten : flags:=F_AE;
+                        gtn : flags:=F_B;
+                        gten : flags:=F_BE;
+                     end
+                   else
+                     case p^.treetype of
+                        equaln : flags:=F_E;
+                        unequaln : flags:=F_NE;
+                        ltn : flags:=F_B;
+                        lten : flags:=F_BE;
+                        gtn : flags:=F_A;
+                        gten : flags:=F_AE;
+                     end;
+                end;
+              p^.location.loc:=LOC_FLAGS;
+              p^.location.resflags:=flags;
+           end;
+      end;
+
+
+  procedure secondaddstring(var p : ptree);
+
+    var
+       swapp : ptree;
+       pushedregs : tpushed;
+       href : treference;
+       pushed,cmpop : boolean;
+
+    begin
+       { string operations are not commutative }
+       if p^.swaped then
+         begin
+            swapp:=p^.left;
+            p^.left:=p^.right;
+            p^.right:=swapp;
+            { because of jump being produced at comparison below: }
+            p^.swaped:=not(p^.swaped);
+         end;
+       case p^.treetype of
+          addn :
+            begin
+               cmpop:=false;
+               secondpass(p^.left);
+               if (p^.left^.treetype<>addn) then
+                 begin
+                    { can only reference be }
+                    { string in register would be funny    }
+                    { therefore produce a temporary string }
+
+                    { release the registers }
+                    del_reference(p^.left^.location.reference);
+                    gettempofsizereference(256,href);
+                    copystring(href,p^.left^.location.reference,255);
+                    ungetiftemp(p^.left^.location.reference);
+
+                    { does not hurt: }
+                    p^.left^.location.loc:=LOC_MEM;
+                    p^.left^.location.reference:=href;
+                 end;
+
+               secondpass(p^.right);
+
+               { on the right we do not need the register anymore too }
+               del_reference(p^.right^.location.reference);
+{               if p^.right^.resulttype^.deftype=orddef then
+                begin
+                  pushusedregisters(pushedregs,$ff);
+                  exprasmlist^.concat(new(pai386,op_ref_reg(
+                     A_LEA,S_L,newreference(p^.left^.location.reference),R_EDI)));
+                  exprasmlist^.concat(new(pai386,op_reg_reg(
+                     A_XOR,S_L,R_EBX,R_EBX)));
+                  reset_reference(href);
+                  href.base:=R_EDI;
+                  exprasmlist^.concat(new(pai386,op_ref_reg(
+                     A_MOV,S_B,newreference(href),R_BL)));
+                  exprasmlist^.concat(new(pai386,op_reg(
+                     A_INC,S_L,R_EBX)));
+                  exprasmlist^.concat(new(pai386,op_reg_ref(
+                     A_MOV,S_B,R_BL,newreference(href))));
+                  href.index:=R_EBX;
+                  if p^.right^.treetype=ordconstn then
+                    exprasmlist^.concat(new(pai386,op_const_ref(
+                       A_MOV,S_L,p^.right^.value,newreference(href))))
+                  else
+                   begin
+                     if p^.right^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
+                      exprasmlist^.concat(new(pai386,op_reg_ref(
+                        A_MOV,S_B,p^.right^.location.register,newreference(href))))
+                     else
+                      begin
+                        exprasmlist^.concat(new(pai386,op_ref_reg(
+                          A_MOV,S_L,newreference(p^.right^.location.reference),R_EAX)));
+                        exprasmlist^.concat(new(pai386,op_reg_ref(
+                          A_MOV,S_B,R_AL,newreference(href))));
+                      end;
+                   end;
+                  popusedregisters(pushedregs);
+                end
+               else }
+                begin
+                  pushusedregisters(pushedregs,$ff);
+                  emitpushreferenceaddr(p^.left^.location.reference);
+                  emitpushreferenceaddr(p^.right^.location.reference);
+                  emitcall('STRCONCAT',true);
+                  maybe_loadesi;
+                  popusedregisters(pushedregs);
+                end;
+
+               set_location(p^.location,p^.left^.location);
+               ungetiftemp(p^.right^.location.reference);
+            end;
+          ltn,lten,gtn,gten,
+          equaln,unequaln :
+            begin
+               cmpop:=true;
+             { generate better code for s='' and s<>'' }
+               if (p^.treetype in [equaln,unequaln]) and
+                  (((p^.left^.treetype=stringconstn) and (p^.left^.values^='')) or
+                   ((p^.right^.treetype=stringconstn) and (p^.right^.values^=''))) then
+                 begin
+                    secondpass(p^.left);
+                    { are too few registers free? }
+                    pushed:=maybe_push(p^.right^.registers32,p);
+                    secondpass(p^.right);
+                    if pushed then restore(p);
+                    del_reference(p^.right^.location.reference);
+                    del_reference(p^.left^.location.reference);
+                    { only one node can be stringconstn }
+                    { else pass 1 would have evaluted   }
+                    { this node                         }
+                    if p^.left^.treetype=stringconstn then
+                      exprasmlist^.concat(new(pai386,op_const_ref(
+                        A_CMP,S_B,0,newreference(p^.right^.location.reference))))
+                    else
+                      exprasmlist^.concat(new(pai386,op_const_ref(
+                        A_CMP,S_B,0,newreference(p^.left^.location.reference))));
+                 end
+               else
+                 begin
+                    pushusedregisters(pushedregs,$ff);
+                    secondpass(p^.left);
+                    del_reference(p^.left^.location.reference);
+                    emitpushreferenceaddr(p^.left^.location.reference);
+                    secondpass(p^.right);
+                    del_reference(p^.right^.location.reference);
+                    emitpushreferenceaddr(p^.right^.location.reference);
+                    emitcall('STRCMP',true);
+                    maybe_loadesi;
+                    popusedregisters(pushedregs);
+                 end;
+               ungetiftemp(p^.left^.location.reference);
+               ungetiftemp(p^.right^.location.reference);
+            end;
+            else Message(sym_e_type_mismatch);
+          end;
+       setaddresult(cmpop,true,p);
+    end;
+
+    procedure secondadd(var p : ptree);
+
+    { is also being used for xor, and "mul", "sub, or and comparative }
+    { operators                                                       }
+
+      label do_normal;
+
+      var
+         swapp : ptree;
+         hregister : tregister;
+         pushed,mboverflow,cmpop : boolean;
+         op : tasmop;
+         pushedregs : tpushed;
+         flags : tresflags;
+         otl,ofl : plabel;
+         power : longint;
+         href : treference;
+         opsize : topsize;
+
+         { true, if unsigned types are compared }
+         unsigned : boolean;
+
+         { is_in_dest if the result is put directly into }
+         { the resulting refernce or varregister }
+         { true, if a small set is handled with the longint code }
+         is_set : boolean;
+         is_in_dest : boolean;
+         { true, if for sets subtractions the extra not should generated }
+         extra_not : boolean;
+
+         mmxbase : tmmxtype;
+
+      begin
+         if (p^.left^.resulttype^.deftype=stringdef) then
+           begin
+              secondaddstring(p);
+              exit;
+           end;
+         unsigned:=false;
+         is_in_dest:=false;
+         extra_not:=false;
+
+         opsize:=S_L;
+
+         { calculate the operator which is more difficult }
+         firstcomplex(p);
+         { handling boolean expressions extra: }
+         if ((p^.left^.resulttype^.deftype=orddef) and
+            (porddef(p^.left^.resulttype)^.typ=bool8bit)) or
+            ((p^.right^.resulttype^.deftype=orddef) and
+            (porddef(p^.right^.resulttype)^.typ=bool8bit)) then
+           begin
+              if (p^.treetype=andn) or (p^.treetype=orn) then
+                begin
+                   p^.location.loc:=LOC_JUMP;
+                   cmpop:=false;
+                   case p^.treetype of
+                     andn : begin
+                               otl:=truelabel;
+                               getlabel(truelabel);
+                               secondpass(p^.left);
+                               maketojumpbool(p^.left);
+                               emitl(A_LABEL,truelabel);
+                               truelabel:=otl;
+                            end;
+                     orn : begin
+                              ofl:=falselabel;
+                              getlabel(falselabel);
+                              secondpass(p^.left);
+                              maketojumpbool(p^.left);
+                              emitl(A_LABEL,falselabel);
+                              falselabel:=ofl;
+                           end;
+                     else Message(sym_e_type_mismatch);
+                   end;
+                  secondpass(p^.right);
+                  maketojumpbool(p^.right);
+                end
+              else if p^.treetype in [unequaln,equaln,xorn] then
+                begin
+                   opsize:=S_B;
+                   if p^.left^.treetype=ordconstn then
+                     begin
+                        swapp:=p^.right;
+                        p^.right:=p^.left;
+                        p^.left:=swapp;
+                        p^.swaped:=not(p^.swaped);
+                     end;
+                   secondpass(p^.left);
+                   p^.location:=p^.left^.location;
+                   { are enough registers free ? }
+                   pushed:=maybe_push(p^.right^.registers32,p);
+                   secondpass(p^.right);
+                   if pushed then restore(p);
+                   goto do_normal;
+                end
+              else Message(sym_e_type_mismatch);
+           end
+         else
+         if (p^.left^.resulttype^.deftype=setdef) and
+            not(psetdef(p^.left^.resulttype)^.settype=smallset) then
+           begin
+              mboverflow:=false;
+              secondpass(p^.left);
+              set_location(p^.location,p^.left^.location);
+              { are too few registers free? }
+              pushed:=maybe_push(p^.right^.registers32,p);
+              secondpass(p^.right);
+              if pushed then restore(p);
+              { not commutative }
+              if p^.swaped then
+                begin
+                   swapp:=p^.left;
+                   p^.left:=p^.right;
+                   p^.right:=swapp;
+                   { because of jump being produced by comparison }
+                   p^.swaped:=not(p^.swaped);
+                end;
+              case p^.treetype of
+                equaln,unequaln:
+                  begin
+                     cmpop:=true;
+                     del_reference(p^.left^.location.reference);
+                     del_reference(p^.right^.location.reference);
+                     pushusedregisters(pushedregs,$ff);
+                     emitpushreferenceaddr(p^.right^.location.reference);
+                     emitpushreferenceaddr(p^.left^.location.reference);
+                     emitcall('SET_COMP_SETS',true);
+                     maybe_loadesi;
+                     popusedregisters(pushedregs);
+                     ungetiftemp(p^.left^.location.reference);
+                     ungetiftemp(p^.right^.location.reference);
+                  end;
+                addn,symdifn,subn,muln:
+                  begin
+                     cmpop:=false;
+                     del_reference(p^.left^.location.reference);
+                     del_reference(p^.right^.location.reference);
+                     href.symbol:=nil;
+                     pushusedregisters(pushedregs,$ff);
+                     gettempofsizereference(32,href);
+                     emitpushreferenceaddr(href);
+                     { wrong place !! was hard to find out
+                     pushusedregisters(pushedregs,$ff);}
+                     emitpushreferenceaddr(p^.right^.location.reference);
+                     emitpushreferenceaddr(p^.left^.location.reference);
+                     case p^.treetype of
+                       subn:
+                         emitcall('SET_SUB_SETS',true);
+                       addn:
+                         emitcall('SET_ADD_SETS',true);
+                       symdifn:
+                         emitcall('SET_SYMDIF_SETS',true);
+                       muln:
+                         emitcall('SET_MUL_SETS',true);
+                     end;
+                     maybe_loadesi;
+                     popusedregisters(pushedregs);
+                     ungetiftemp(p^.left^.location.reference);
+                     ungetiftemp(p^.right^.location.reference);
+                     p^.location.loc:=LOC_MEM;
+                     stringdispose(p^.location.reference.symbol);
+                     p^.location.reference:=href;
+                  end;
+                else Message(sym_e_type_mismatch);
+              end;
+           end
+         else
+           begin
+              { in case of constant put it to the left }
+              if p^.left^.treetype=ordconstn then
+                begin
+                   swapp:=p^.right;
+                   p^.right:=p^.left;
+                   p^.left:=swapp;
+                   p^.swaped:=not(p^.swaped);
+                end;
+              secondpass(p^.left);
+              { this will be complicated as
+               a lot of code below assumes that
+               p^.location and p^.left^.location are the same }
+
+{$ifdef test_dest_loc}
+              if dest_loc_known and (dest_loc_tree=p) and
+                 ((dest_loc.loc=LOC_REGISTER) or (dest_loc.loc=LOC_CREGISTER)) then
+                begin
+                   set_location(p^.location,dest_loc);
+                   in_dest_loc:=true;
+                   is_in_dest:=true;
+                end
+              else
+{$endif test_dest_loc}
+                set_location(p^.location,p^.left^.location);
+              { are too few registers free? }
+              pushed:=maybe_push(p^.right^.registers32,p);
+              secondpass(p^.right);
+              if pushed then restore(p);
+              if (p^.left^.resulttype^.deftype=pointerdef) or
+
+                 (p^.right^.resulttype^.deftype=pointerdef) or
+
+                 ((p^.right^.resulttype^.deftype=objectdef) and
+                  pobjectdef(p^.right^.resulttype)^.isclass and
+                 (p^.left^.resulttype^.deftype=objectdef) and
+                  pobjectdef(p^.left^.resulttype)^.isclass
+                 ) or
+
+                 (p^.left^.resulttype^.deftype=classrefdef) or
+
+                 (p^.left^.resulttype^.deftype=procvardef) or
+
+                 (p^.left^.resulttype^.deftype=enumdef) or
+
+                 ((p^.left^.resulttype^.deftype=orddef) and
+                 (porddef(p^.left^.resulttype)^.typ=s32bit)) or
+                 ((p^.right^.resulttype^.deftype=orddef) and
+                 (porddef(p^.right^.resulttype)^.typ=s32bit)) or
+
+                ((p^.left^.resulttype^.deftype=orddef) and
+                 (porddef(p^.left^.resulttype)^.typ=u32bit)) or
+                 ((p^.right^.resulttype^.deftype=orddef) and
+                 (porddef(p^.right^.resulttype)^.typ=u32bit)) or
+
+                { as well as small sets }
+                ((p^.left^.resulttype^.deftype=setdef) and
+                 (psetdef(p^.left^.resulttype)^.settype=smallset)
+                ) then
+                begin
+           do_normal:
+                   mboverflow:=false;
+                   cmpop:=false;
+                   if (p^.left^.resulttype^.deftype=pointerdef) or
+                      (p^.right^.resulttype^.deftype=pointerdef) or
+                      ((p^.left^.resulttype^.deftype=orddef) and
+                      (porddef(p^.left^.resulttype)^.typ=u32bit)) or
+                      ((p^.right^.resulttype^.deftype=orddef) and
+                      (porddef(p^.right^.resulttype)^.typ=u32bit)) then
+                     unsigned:=true;
+                   is_set:=p^.resulttype^.deftype=setdef;
+
+                   case p^.treetype of
+                      addn : begin
+                                if is_set then
+                                  begin
+                                     op:=A_OR;
+                                     mboverflow:=false;
+                                     unsigned:=false;
+                                  end
+                                else
+                                  begin
+                                     op:=A_ADD;
+                                     mboverflow:=true;
+                                  end;
+                             end;
+                      symdifn : begin
+                                { the symetric diff is only for sets }
+                                if is_set then
+                                  begin
+                                     op:=A_XOR;
+                                     mboverflow:=false;
+                                     unsigned:=false;
+                                  end
+                                else
+                                  begin
+                                     Message(sym_e_type_mismatch);
+                                  end;
+                             end;
+                      muln : begin
+                                if is_set then
+                                  begin
+                                     op:=A_AND;
+                                     mboverflow:=false;
+                                     unsigned:=false;
+                                  end
+                                else
+                                  begin
+                                     if unsigned then
+                                       op:=A_MUL
+                                     else
+                                       op:=A_IMUL;
+                                     mboverflow:=true;
+                                  end;
+                             end;
+                      subn : begin
+                                if is_set then
+                                  begin
+                                     op:=A_AND;
+                                     mboverflow:=false;
+                                     unsigned:=false;
+                                     extra_not:=true;
+                                  end
+                                else
+                                  begin
+                                     op:=A_SUB;
+                                     mboverflow:=true;
+                                  end;
+                             end;
+                      ltn,lten,gtn,gten,
+                      equaln,unequaln :
+                             begin
+                                op:=A_CMP;
+                                cmpop:=true;
+                             end;
+                      xorn : op:=A_XOR;
+                      orn : op:=A_OR;
+                      andn : op:=A_AND;
+                      else Message(sym_e_type_mismatch);
+                   end;
+                   { left and right no register?  }
+                   { then one must be demanded    }
+                   if (p^.left^.location.loc<>LOC_REGISTER) and
+                     (p^.right^.location.loc<>LOC_REGISTER) then
+                     begin
+                        { register variable ? }
+                        if (p^.left^.location.loc=LOC_CREGISTER) then
+                          begin
+                             { it is OK if this is the destination }
+                             if is_in_dest then
+                               begin
+                                  hregister:=p^.location.register;
+                                  emit_reg_reg(A_MOV,opsize,p^.left^.location.register,
+                                    hregister);
+                               end
+                             else
+                             if cmpop then
+                               begin
+                                  { do not disturb the register }
+                                  hregister:=p^.location.register;
+                               end
+                             else
+                               begin
+                                  case opsize of
+                                     S_L : hregister:=getregister32;
+                                     S_B : hregister:=reg32toreg8(getregister32);
+                                  end;
+                                  emit_reg_reg(A_MOV,opsize,p^.left^.location.register,
+                                    hregister);
+                               end
+
+                          end
+                        else
+                          begin
+                             del_reference(p^.left^.location.reference);
+
+                             if is_in_dest then
+                               begin
+                                  hregister:=p^.location.register;
+                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
+                                  newreference(p^.left^.location.reference),hregister)));
+                               end
+                             else
+                               begin
+                                  { first give free, then demand new register }
+                                  case opsize of
+                                     S_L : hregister:=getregister32;
+                                     S_B : hregister:=reg32toreg8(getregister32);
+                                  end;
+                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
+                                    newreference(p^.left^.location.reference),hregister)));
+                               end;
+                          end;
+
+                        p^.location.loc:=LOC_REGISTER;
+                        p^.location.register:=hregister;
+
+                     end
+                   else
+                     { if on the right the register then swap }
+                     if (p^.right^.location.loc=LOC_REGISTER) then
+                       begin
+                          swap_location(p^.location,p^.right^.location);
+
+                          { newly swapped also set swapped flag }
+                          p^.swaped:=not(p^.swaped);
+                       end;
+                   { at this point, p^.location.loc should be LOC_REGISTER }
+                   { and p^.location.register should be a valid register   }
+                   { containing the left result                            }
+                   if p^.right^.location.loc<>LOC_REGISTER then
+                     begin
+                        if (p^.treetype=subn) and p^.swaped then
+                          begin
+                             if p^.right^.location.loc=LOC_CREGISTER then
+                               begin
+                                  if extra_not then
+                                    exprasmlist^.concat(new(pai386,op_reg(A_NOT,opsize,p^.location.register)));
+
+                                  emit_reg_reg(A_MOV,opsize,p^.right^.location.register,R_EDI);
+                                  emit_reg_reg(op,opsize,p^.location.register,R_EDI);
+                                  emit_reg_reg(A_MOV,opsize,R_EDI,p^.location.register);
+                               end
+                             else
+                               begin
+                                  if extra_not then
+                                    exprasmlist^.concat(new(pai386,op_reg(A_NOT,opsize,p^.location.register)));
+
+                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
+                                    newreference(p^.right^.location.reference),R_EDI)));
+                                  exprasmlist^.concat(new(pai386,op_reg_reg(op,opsize,p^.location.register,R_EDI)));
+                                  exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,opsize,R_EDI,p^.location.register)));
+                                  del_reference(p^.right^.location.reference);
+                               end;
+                          end
+                        else
+                          begin
+                             if (p^.right^.treetype=ordconstn) and
+                                (op=A_CMP) and
+                                (p^.right^.value=0) then
+                               begin
+                                  exprasmlist^.concat(new(pai386,op_reg_reg(A_TEST,opsize,p^.location.register,
+                                    p^.location.register)));
+                               end
+                             else if (p^.right^.treetype=ordconstn) and
+                                (op=A_ADD) and
+                                (p^.right^.value=1) then
+                               begin
+                                  exprasmlist^.concat(new(pai386,op_reg(A_INC,opsize,
+                                    p^.location.register)));
+                               end
+                             else if (p^.right^.treetype=ordconstn) and
+                                (op=A_SUB) and
+                                (p^.right^.value=1) then
+                               begin
+                                  exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize,
+                                    p^.location.register)));
+                               end
+                             else if (p^.right^.treetype=ordconstn) and
+                                (op=A_IMUL) and
+                                (ispowerof2(p^.right^.value,power)) then
+                               begin
+                                  exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,opsize,power,
+                                    p^.location.register)));
+                               end
+                             else
+                               begin
+                                  if (p^.right^.location.loc=LOC_CREGISTER) then
+                                    begin
+                                       if extra_not then
+                                         begin
+                                            emit_reg_reg(A_MOV,S_L,p^.right^.location.register,R_EDI);
+                                            exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,R_EDI)));
+                                            emit_reg_reg(A_AND,S_L,R_EDI,
+                                              p^.location.register);
+                                         end
+                                       else
+                                         begin
+                                            emit_reg_reg(op,opsize,p^.right^.location.register,
+                                              p^.location.register);
+                                         end;
+                                    end
+                                  else
+                                    begin
+                                       if extra_not then
+                                         begin
+                                            exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(
+                                              p^.right^.location.reference),R_EDI)));
+                                            exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,R_EDI)));
+                                            emit_reg_reg(A_AND,S_L,R_EDI,
+                                              p^.location.register);
+                                         end
+                                       else
+                                         begin
+                                            exprasmlist^.concat(new(pai386,op_ref_reg(op,opsize,newreference(
+                                              p^.right^.location.reference),p^.location.register)));
+                                         end;
+                                       del_reference(p^.right^.location.reference);
+                                    end;
+                               end;
+                          end;
+                     end
+                   else
+                     begin
+                        { when swapped another result register }
+                        if (p^.treetype=subn) and p^.swaped then
+                          begin
+                             if extra_not then
+                               exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register)));
+
+                             exprasmlist^.concat(new(pai386,op_reg_reg(op,opsize,
+                               p^.location.register,p^.right^.location.register)));
+                               swap_location(p^.location,p^.right^.location);
+                               { newly swapped also set swapped flag }
+                               { just to maintain ordering           }
+                               p^.swaped:=not(p^.swaped);
+                          end
+                        else
+                          begin
+                             if extra_not then
+                               exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.right^.location.register)));
+                             exprasmlist^.concat(new(pai386,op_reg_reg(op,opsize,
+                               p^.right^.location.register,
+                               p^.location.register)));
+                          end;
+                        case opsize of
+                           S_L : ungetregister32(p^.right^.location.register);
+                           S_B : ungetregister32(reg8toreg32(p^.right^.location.register));
+                        end;
+                     end;
+
+                   if cmpop then
+                     case opsize of
+                        S_L : ungetregister32(p^.location.register);
+                        S_B : ungetregister32(reg8toreg32(p^.location.register));
+                     end;
+
+                   { only in case of overflow operations }
+                   { produce overflow code }
+                   if mboverflow then
+                     emitoverflowcheck;
+                end
+              else if ((p^.left^.resulttype^.deftype=orddef) and
+                 (porddef(p^.left^.resulttype)^.typ=uchar)) then
+                begin
+                   case p^.treetype of
+                      ltn,lten,gtn,gten,
+                      equaln,unequaln :
+                                cmpop:=true;
+                      else Message(sym_e_type_mismatch);
+                   end;
+                   unsigned:=true;
+                   { left and right no register? }
+                   { the one must be demanded    }
+                   if (p^.location.loc<>LOC_REGISTER) and
+                     (p^.right^.location.loc<>LOC_REGISTER) then
+                     begin
+                        if p^.location.loc=LOC_CREGISTER then
+                          begin
+                             if cmpop then
+                               { do not disturb register }
+                               hregister:=p^.location.register
+                             else
+                               begin
+                                  hregister:=reg32toreg8(getregister32);
+                                  emit_reg_reg(A_MOV,S_B,p^.location.register,
+                                    hregister);
+                               end;
+                          end
+                        else
+                          begin
+                             del_reference(p^.location.reference);
+
+                             { first give free then demand new register }
+                             hregister:=reg32toreg8(getregister32);
+                             exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_B,newreference(p^.location.reference),
+                               hregister)));
+                          end;
+                        p^.location.loc:=LOC_REGISTER;
+                        p^.location.register:=hregister;
+                     end;
+
+                   { now p always a register }
+
+                   if (p^.right^.location.loc=LOC_REGISTER) and
+                      (p^.location.loc<>LOC_REGISTER) then
+                     begin
+                       swap_location(p^.location,p^.right^.location);
+
+                        { newly swapped also set swapped flag }
+                        p^.swaped:=not(p^.swaped);
+                     end;
+                   if p^.right^.location.loc<>LOC_REGISTER then
+                     begin
+                        if p^.right^.location.loc=LOC_CREGISTER then
+                          begin
+                             emit_reg_reg(A_CMP,S_B,
+                                p^.right^.location.register,p^.location.register);
+                          end
+                        else
+                          begin
+                             exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,S_B,newreference(
+                                p^.right^.location.reference),p^.location.register)));
+                             del_reference(p^.right^.location.reference);
+                          end;
+                     end
+                   else
+                     begin
+                        emit_reg_reg(A_CMP,S_B,p^.right^.location.register,
+                          p^.location.register);
+                        ungetregister32(reg8toreg32(p^.right^.location.register));
+                     end;
+                   ungetregister32(reg8toreg32(p^.location.register));
+                end
+              else if (p^.left^.resulttype^.deftype=floatdef) and
+                  (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then
+                 begin
+                    { real constants to the left }
+                    if p^.left^.treetype=realconstn then
+                      begin
+                         swapp:=p^.right;
+                         p^.right:=p^.left;
+                         p^.left:=swapp;
+                         p^.swaped:=not(p^.swaped);
+                      end;
+                    cmpop:=false;
+                    case p^.treetype of
+                       addn : op:=A_FADDP;
+                       muln : op:=A_FMULP;
+                       subn : op:=A_FSUBP;
+                       slashn : op:=A_FDIVP;
+                       ltn,lten,gtn,gten,
+                       equaln,unequaln : begin
+                                            op:=A_FCOMPP;
+                                            cmpop:=true;
+                                         end;
+                       else Message(sym_e_type_mismatch);
+                    end;
+
+                    if (p^.right^.location.loc<>LOC_FPU) then
+                      begin
+                         floatload(pfloatdef(p^.right^.resulttype)^.typ,p^.right^.location.reference);
+                         if (p^.left^.location.loc<>LOC_FPU) then
+                           floatload(pfloatdef(p^.left^.resulttype)^.typ,p^.left^.location.reference)
+                         { left was on the stack => swap }
+                         else
+                           p^.swaped:=not(p^.swaped);
+
+                         { releases the right reference }
+                         del_reference(p^.right^.location.reference);
+                      end
+                    { the nominator in st0 }
+                    else if (p^.left^.location.loc<>LOC_FPU) then
+                      floatload(pfloatdef(p^.left^.resulttype)^.typ,p^.left^.location.reference)
+                    { fpu operands are always in the wrong order on the stack }
+                    else
+                      p^.swaped:=not(p^.swaped);
+
+                    { releases the left reference }
+                    if (p^.left^.location.loc<>LOC_FPU) then
+                      del_reference(p^.left^.location.reference);
+
+                    { if we swaped the tree nodes, then use the reverse operator }
+                    if p^.swaped then
+                      begin
+                         if (p^.treetype=slashn) then
+                           op:=A_FDIVRP
+                         else if (p^.treetype=subn) then
+                           op:=A_FSUBRP;
+                      end;
+                    { to avoid the pentium bug
+                    if (op=FDIVP) and (opt_processors=pentium) then
+                      exprasmlist^.concat(new(pai386,op_CALL,S_NO,'EMUL_FDIVP')
+                    else
+                    }
+                    { the Intel assemblers want operands }
+                    if op<>A_FCOMPP then
+                       exprasmlist^.concat(new(pai386,op_reg_reg(op,S_NO,R_ST,R_ST1)))
+                    else
+                      exprasmlist^.concat(new(pai386,op_none(op,S_NO)));
+                    { on comparison load flags }
+                    if cmpop then
+                      begin
+                         if not(R_EAX in unused) then
+                           emit_reg_reg(A_MOV,S_L,R_EAX,R_EDI);
+                         exprasmlist^.concat(new(pai386,op_reg(A_FNSTS,S_W,R_AX)));
+                         exprasmlist^.concat(new(pai386,op_none(A_SAHF,S_NO)));
+                         if not(R_EAX in unused) then
+                           emit_reg_reg(A_MOV,S_L,R_EDI,R_EAX);
+                         if p^.swaped then
+                           case p^.treetype of
+                              equaln : flags:=F_E;
+                              unequaln : flags:=F_NE;
+                              ltn : flags:=F_A;
+                              lten : flags:=F_AE;
+                              gtn : flags:=F_B;
+                              gten : flags:=F_BE;
+                           end
+                         else
+                           case p^.treetype of
+                              equaln : flags:=F_E;
+                              unequaln : flags:=F_NE;
+                              ltn : flags:=F_B;
+                              lten : flags:=F_BE;
+                              gtn : flags:=F_A;
+                              gten : flags:=F_AE;
+                           end;
+                         p^.location.loc:=LOC_FLAGS;
+                         p^.location.resflags:=flags;
+                         cmpop:=false;
+                      end
+                    else
+                      p^.location.loc:=LOC_FPU;
+                 end
+{$ifdef SUPPORT_MMX}
+               else if is_mmx_able_array(p^.left^.resulttype) then
+                 begin
+                   cmpop:=false;
+                   mmxbase:=mmx_type(p^.left^.resulttype);
+                   case p^.treetype of
+                      addn : begin
+                                if (cs_mmx_saturation in aktswitches^) then
+                                  begin
+                                     case mmxbase of
+                                        mmxs8bit:
+                                          op:=A_PADDSB;
+                                        mmxu8bit:
+                                          op:=A_PADDUSB;
+                                        mmxs16bit,mmxfixed16:
+                                          op:=A_PADDSB;
+                                        mmxu16bit:
+                                          op:=A_PADDUSW;
+                                     end;
+                                  end
+                                else
+                                  begin
+                                     case mmxbase of
+                                        mmxs8bit,mmxu8bit:
+                                          op:=A_PADDB;
+                                        mmxs16bit,mmxu16bit,mmxfixed16:
+                                          op:=A_PADDW;
+                                        mmxs32bit,mmxu32bit:
+                                          op:=A_PADDD;
+                                     end;
+                                  end;
+                             end;
+                      muln : begin
+                                case mmxbase of
+                                   mmxs16bit,mmxu16bit:
+                                     op:=A_PMULLW;
+                                   mmxfixed16:
+                                     op:=A_PMULHW;
+                                end;
+                             end;
+                      subn : begin
+                                if (cs_mmx_saturation in aktswitches^) then
+                                  begin
+                                     case mmxbase of
+                                        mmxs8bit:
+                                          op:=A_PSUBSB;
+                                        mmxu8bit:
+                                          op:=A_PSUBUSB;
+                                        mmxs16bit,mmxfixed16:
+                                          op:=A_PSUBSB;
+                                        mmxu16bit:
+                                          op:=A_PSUBUSW;
+                                     end;
+                                  end
+                                else
+                                  begin
+                                     case mmxbase of
+                                        mmxs8bit,mmxu8bit:
+                                          op:=A_PSUBB;
+                                        mmxs16bit,mmxu16bit,mmxfixed16:
+                                          op:=A_PSUBW;
+                                        mmxs32bit,mmxu32bit:
+                                          op:=A_PSUBD;
+                                     end;
+                                  end;
+                             end;
+                      {
+                      ltn,lten,gtn,gten,
+                      equaln,unequaln :
+                             begin
+                                op:=A_CMP;
+                                cmpop:=true;
+                             end;
+                      }
+                      xorn:
+                        op:=A_PXOR;
+                      orn:
+                        op:=A_POR;
+                      andn:
+                        op:=A_PAND;
+                      else Message(sym_e_type_mismatch);
+                   end;
+                   { left and right no register?  }
+                   { then one must be demanded    }
+                   if (p^.left^.location.loc<>LOC_MMXREGISTER) and
+                     (p^.right^.location.loc<>LOC_MMXREGISTER) then
+                     begin
+                        { register variable ? }
+                        if (p^.left^.location.loc=LOC_CMMXREGISTER) then
+                          begin
+                             { it is OK if this is the destination }
+                             if is_in_dest then
+                               begin
+                                  hregister:=p^.location.register;
+                                  emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register,
+                                    hregister);
+                               end
+                             else
+                               begin
+                                  hregister:=getregistermmx;
+                                  emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register,
+                                    hregister);
+                               end
+
+                          end
+                        else
+                          begin
+                             del_reference(p^.left^.location.reference);
+
+                             if is_in_dest then
+                               begin
+                                  hregister:=p^.location.register;
+                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVQ,S_NO,
+                                  newreference(p^.left^.location.reference),hregister)));
+                               end
+                             else
+                               begin
+                                  hregister:=getregistermmx;
+                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVQ,S_NO,
+                                    newreference(p^.left^.location.reference),hregister)));
+                               end;
+                          end;
+
+                        p^.location.loc:=LOC_MMXREGISTER;
+                        p^.location.register:=hregister;
+
+                     end
+                   else
+                     { if on the right the register then swap }
+                     if (p^.right^.location.loc=LOC_MMXREGISTER) then
+                       begin
+                          swap_location(p^.location,p^.right^.location);
+
+                          { newly swapped also set swapped flag }
+                          p^.swaped:=not(p^.swaped);
+                       end;
+                   { at this point, p^.location.loc should be LOC_MMXREGISTER }
+                   { and p^.location.register should be a valid register      }
+                   { containing the left result                               }
+                   if p^.right^.location.loc<>LOC_MMXREGISTER then
+                     begin
+                        if (p^.treetype=subn) and p^.swaped then
+                          begin
+                             if p^.right^.location.loc=LOC_CMMXREGISTER then
+                               begin
+                                  emit_reg_reg(A_MOVQ,S_NO,p^.right^.location.register,R_MM7);
+                                  emit_reg_reg(op,S_NO,p^.location.register,R_EDI);
+                                  emit_reg_reg(A_MOVQ,S_NO,R_MM7,p^.location.register);
+                               end
+                             else
+                               begin
+
+                                  exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVQ,S_NO,
+                                    newreference(p^.right^.location.reference),R_MM7)));
+                                  exprasmlist^.concat(new(pai386,op_reg_reg(op,S_NO,p^.location.register,
+                                    R_MM7)));
+                                  exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVQ,S_NO,
+                                    R_MM7,p^.location.register)));
+                                  del_reference(p^.right^.location.reference);
+                               end;
+                          end
+                        else
+                          begin
+                             if (p^.right^.location.loc=LOC_CREGISTER) then
+                               begin
+                                  emit_reg_reg(op,S_NO,p^.right^.location.register,
+                                    p^.location.register);
+                               end
+                             else
+                               begin
+                                  exprasmlist^.concat(new(pai386,op_ref_reg(op,S_NO,newreference(
+                                    p^.right^.location.reference),p^.location.register)));
+                                  del_reference(p^.right^.location.reference);
+                               end;
+                          end;
+                     end
+                   else
+                     begin
+                        { when swapped another result register }
+                        if (p^.treetype=subn) and p^.swaped then
+                          begin
+                             exprasmlist^.concat(new(pai386,op_reg_reg(op,S_NO,
+                               p^.location.register,p^.right^.location.register)));
+                               swap_location(p^.location,p^.right^.location);
+                               { newly swapped also set swapped flag }
+                               { just to maintain ordering           }
+                               p^.swaped:=not(p^.swaped);
+                          end
+                        else
+                          begin
+                             exprasmlist^.concat(new(pai386,op_reg_reg(op,S_NO,
+                               p^.right^.location.register,
+                               p^.location.register)));
+                          end;
+                        ungetregistermmx(p^.right^.location.register);
+                     end;
+                end
+{$endif SUPPORT_MMX}
+              else Message(sym_e_type_mismatch);
+           end;
+       setaddresult(cmpop,unsigned,p);
+    end;
+
+{
+     $Log$
+     Revision 1.1  1998-03-25 11:18:12  root
+     Initial revision
+
+     Revision 1.15  1998/03/10 23:48:36  florian
+       * a couple of bug fixes to get the compiler with -OGaxz compiler, sadly
+         enough, it doesn't run
+
+     Revision 1.14  1998/03/10 01:17:18  peter
+       * all files have the same header
+       * messages are fully implemented, EXTDEBUG uses Comment()
+       + AG... files for the Assembler generation
+
+     Revision 1.13  1998/03/09 10:44:38  peter
+       + string='', string<>'', string:='', string:=char optimizes (the first 2
+         were already in cg68k2)
+
+     Revision 1.12  1998/03/06 00:52:16  peter
+       * replaced all old messages from errore.msg, only ExtDebug and some
+         Comment() calls are left
+       * fixed options.pas
+
+     Revision 1.11  1998/03/02 01:48:30  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.10  1998/02/15 21:27:50  florian
+     *** empty log message ***
+}

compiler/cobjects.pas

@@ -0,0 +1,1085 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl
+
+    This module provides some basic objects
+
+    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.
+
+ ****************************************************************************
+}
+
+{$ifdef tp}
+  {$E+,N+,D+,F+}
+{$endif}
+{$I-}
+{$R-}{ necessary for crc calculation }
+
+unit cobjects;
+
+  interface
+
+    uses
+       strings
+{$ifndef linux}
+       ,dos
+{$else}
+       ,linux
+{$endif}
+      ;
+
+    type
+       pstring = ^string;
+
+       { some help data types }
+       pstringitem = ^tstringitem;
+
+       tstringitem = record
+          data : pstring;
+          next : pstringitem;
+       end;
+
+       plinkedlist_item = ^tlinkedlist_item;
+
+       tlinkedlist_item = object
+          next,last : plinkedlist_item;
+          { does nothing }
+          constructor init;
+          destructor done;virtual;
+       end;
+
+       pstring_item = ^tstring_item;
+
+       tstring_item = object(tlinkedlist_item)
+          str : pstring;
+          constructor init(const s : string);
+          destructor done;virtual;
+       end;
+
+       plinkedlist = ^tlinkedlist;
+
+       { this implements a double linked list }
+       tlinkedlist = object
+          first,last : plinkedlist_item;
+          constructor init;
+          destructor done;
+
+          { disposes the items of the list }
+          procedure clear;
+
+          { concats a new item at the end }
+          procedure concat(p : plinkedlist_item);
+
+          { inserts a new item at the begin }
+          procedure insert(p : plinkedlist_item);
+
+          { inserts another list at the begin and make this list empty }
+          procedure insertlist(p : plinkedlist);
+
+          { concats another list at the end and make this list empty }
+          procedure concatlist(p : plinkedlist);
+
+          { removes p from the list (p isn't disposed) }
+          { it's not tested if p is in the list !      }
+          procedure remove(p : plinkedlist_item);
+       end;
+
+       { String Queue}
+       PStringQueue=^TStringQueue;
+       TStringQueue=object
+         first,last : PStringItem;
+         constructor Init;
+         destructor Done;
+         function Empty:boolean;
+         function Get:string;
+         procedure Insert(const s:string);
+         procedure Concat(const s:string);
+         procedure Clear;
+       end;
+
+       { string container }
+       pstringcontainer = ^tstringcontainer;
+
+       tstringcontainer = object
+          root,last : pstringitem;
+
+          { if this is set to true, doubles are allowed }
+          { true is default                             }
+          doubles : boolean;
+          constructor init;
+          destructor done;
+
+          { true is the container empty }
+          function empty:boolean;
+
+
+          { inserts a string }
+          procedure insert(const s : string);
+
+          { gets a string }
+          function get : string;
+
+          { deletes all strings }
+          procedure clear;
+       end;
+
+       pbufferedfile = ^tbufferedfile;
+
+       { this is implemented to allow buffered binary I/O }
+       tbufferedfile = object
+           f : file;
+           buf : pchar;
+           bufsize,buflast,bufpos : longint;
+
+           { 0 closed, 1 input, 2 output }
+           iomode : byte;
+
+           { true, if the compile should change the endian of the output }
+           change_endian : boolean;
+
+           { calcules a crc for the file,                                    }
+           { but it's assumed, that there no seek while do_crc is true       }
+           do_crc : boolean;
+           crc : longint;
+
+           { inits a buffer with the size bufsize which is assigned to }
+           { the file  filename                                        }
+           constructor init(const filename : string;_bufsize : longint);
+
+           { closes the file, if needed, and releases the memory }
+           destructor done;virtual;
+
+           { opens the file for input, other accesses are rejected }
+           procedure reset;
+
+           { opens the file for output, other accesses are rejected }
+           procedure rewrite;
+
+           { reads or writes the buffer from or to disk }
+           procedure flush;
+
+           { writes a string to the file }
+           { the string is written without a length byte }
+           procedure write_string(const s : string);
+
+           { writes a zero terminated string }
+           procedure write_pchar(p : pchar);
+
+           { write specific data types, takes care of }
+           { byte order                               }
+           procedure write_byte(b : byte);
+           procedure write_word(w : word);
+           procedure write_long(l : longint);
+           procedure write_double(d : double);
+
+           { writes any data }
+           procedure write_data(var data;count : longint);
+
+           { reads any data }
+           procedure read_data(var data;bytes : longint;var count : longint);
+
+           { closes the file and releases the buffer }
+           procedure close;
+
+{$ifdef MAKELIB}
+           { used for making tiny files for libs }
+           procedure changename(filename : string);
+{$endif MAKELIB}
+
+           { goto the given position }
+           procedure seek(l : longint);
+
+           { installes an user defined buffer      }
+           { and releases the old one, but be      }
+           { careful, if the old buffer contains   }
+           { data, this data is lost               }
+           procedure setbuf(p : pchar;s : longint);
+
+           { reads the file time stamp of the file, }
+           { the file must be opened                }
+           function getftime : longint;
+
+           { returns filesize }
+           function getsize : longint;
+
+           { returns the path }
+           function getpath : string;
+
+           { resets the crc }
+           procedure clear_crc;
+
+           { returns the crc }
+           function getcrc : longint;
+       end;
+
+    { releases the string p and assignes nil to p }
+    { if p=nil then freemem isn't called          }
+    procedure stringdispose(var p : pstring);
+
+    { allocates mem for a copy of s, copies s to this mem and returns }
+    { a pointer to this mem                                           }
+    function stringdup(const s : string) : pstring;
+
+    { allocates memory for s and copies s as zero terminated string
+      to that mem and returns a pointer to that mem }
+    function strpnew(const s : string) : pchar;
+
+    { makes a char lowercase, with spanish, french and german char set }
+    function lowercase(c : char) : char;
+
+    { makes zero terminated string to a pascal string }
+    { the data in p is modified and p is returned     }
+    function pchar2pstring(p : pchar) : pstring;
+
+    { ambivalent to pchar2pstring }
+    function pstring2pchar(p : pstring) : pchar;
+
+  implementation
+
+    function pchar2pstring(p : pchar) : pstring;
+
+      var
+         w : word;
+         i : longint;
+
+      begin
+         w:=strlen(p);
+         for i:=w-1 downto 0 do
+           p[i+1]:=p[i];
+         p[0]:=chr(w);
+         pchar2pstring:=pstring(p);
+      end;
+
+    function pstring2pchar(p : pstring) : pchar;
+
+      var
+         w : word;
+         i : longint;
+
+      begin
+         w:=ord(p^[0]);
+         for i:=1 to w do
+           p^[i-1]:=p^[i];
+         p^[w]:=#0;
+         pstring2pchar:=pchar(p);
+      end;
+
+    function lowercase(c : char) : char;
+
+       begin
+          case c of
+             #65..#90 : c := chr(ord (c) + 32);
+             #154 : c:=#129;  { german }
+             #142 : c:=#132;  { german }
+             #153 : c:=#148;  { german }
+             #144 : c:=#130;  { french }
+             #128 : c:=#135;  { french }
+             #143 : c:=#134;  { swedish/norge (?) }
+             #165 : c:=#164;  { spanish }
+             #228 : c:=#229;  { greek }
+             #226 : c:=#231;  { greek }
+             #232 : c:=#227;  { greek }
+          end;
+          lowercase := c;
+       end;
+
+    function strpnew(const s : string) : pchar;
+      var
+         p : pchar;
+      begin
+         getmem(p,length(s)+1);
+         strpcopy(p,s);
+         strpnew:=p;
+      end;
+
+    procedure stringdispose(var p : pstring);
+      begin
+         if assigned(p) then
+           freemem(p,length(p^)+1);
+         p:=nil;
+      end;
+
+    function stringdup(const s : string) : pstring;
+
+      var
+         p : pstring;
+
+      begin
+         getmem(p,length(s)+1);
+         p^:=s;
+         stringdup:=p;
+      end;
+
+{****************************************************************************
+                                  TStringQueue
+****************************************************************************}
+
+constructor TStringQueue.Init;
+begin
+  first:=nil;
+end;
+
+
+function TStringQueue.Empty:boolean;
+begin
+  Empty:=(first=nil);
+end;
+
+
+function TStringQueue.Get:string;
+var
+  hp : pstringitem;
+begin
+  if first=nil then
+   begin
+     Get:='';
+     exit;
+   end;
+  Get:=first^.data^;
+  stringdispose(first^.data);
+  hp:=first;
+  first:=first^.next;
+  dispose(hp);
+end;
+
+
+procedure TStringQueue.Insert(const s:string);
+var
+  hp : pstringitem;
+begin
+  new(hp);
+  hp^.next:=first;
+  hp^.data:=stringdup(s);
+  first:=hp;
+  if last=nil then
+   last:=hp;
+end;
+
+
+procedure TStringQueue.Concat(const s:string);
+var
+  hp : pstringitem;
+begin
+  new(hp);
+  hp^.next:=nil;
+  hp^.data:=stringdup(s);
+  if first=nil then
+   first:=hp
+  else
+   last^.next:=hp;
+  last:=hp;
+end;
+
+
+procedure TStringQueue.Clear;
+var
+  hp : pstringitem;
+begin
+  while (first<>nil) do
+   begin
+     hp:=first;
+     stringdispose(first^.data);
+     first:=first^.next;
+     dispose(hp);
+   end;
+end;
+
+
+destructor TStringQueue.Done;
+begin
+  Clear;
+end;
+
+{****************************************************************************
+                           TSTRINGCONTAINER
+ ****************************************************************************}
+
+    constructor tstringcontainer.init;
+
+      begin
+         root:=nil;
+         last:=nil;
+         doubles:=true;
+      end;
+
+    destructor tstringcontainer.done;
+
+      begin
+         clear;
+      end;
+
+    function tstringcontainer.empty:boolean;
+
+
+      begin
+        empty:=(root=nil);
+      end;
+
+
+    procedure tstringcontainer.insert(const s : string);
+
+      var
+         hp : pstringitem;
+
+      begin
+         if not(doubles) then
+           begin
+              hp:=root;
+              while assigned(hp) do
+                begin
+                   if hp^.data^=s then exit;
+                   hp:=hp^.next;
+                end;
+           end;
+         new(hp);
+         hp^.next:=nil;
+         hp^.data:=stringdup(s);
+         if root=nil then root:=hp
+           else last^.next:=hp;
+         last:=hp;
+      end;
+
+    procedure tstringcontainer.clear;
+
+      var
+         hp : pstringitem;
+
+      begin
+         hp:=root;
+         while assigned(hp) do
+           begin
+              stringdispose(hp^.data);
+              root:=hp^.next;
+              dispose(hp);
+              hp:=root;
+           end;
+         last:=nil;
+         root:=nil;
+      end;
+
+    function tstringcontainer.get : string;
+
+      var
+         hp : pstringitem;
+
+      begin
+         if root=nil then
+          get:=''
+         else
+          begin
+            get:=root^.data^;
+            hp:=root;
+            root:=root^.next;
+            stringdispose(hp^.data);
+            dispose(hp);
+          end;
+      end;
+
+{****************************************************************************
+                            TLINKEDLIST_ITEM
+ ****************************************************************************}
+
+    constructor tlinkedlist_item.init;
+
+      begin
+         last:=nil;
+         next:=nil;
+      end;
+
+    destructor tlinkedlist_item.done;
+
+      begin
+      end;
+
+{****************************************************************************
+                            TSTRING_ITEM
+ ****************************************************************************}
+
+    constructor tstring_item.init(const s : string);
+
+      begin
+         str:=stringdup(s);
+      end;
+
+    destructor tstring_item.done;
+
+      begin
+         stringdispose(str);
+         inherited done;
+      end;
+
+{****************************************************************************
+                               TLINKEDLIST
+ ****************************************************************************}
+
+    constructor tlinkedlist.init;
+
+      begin
+         first:=nil;
+         last:=nil;
+      end;
+
+    destructor tlinkedlist.done;
+
+      begin
+         clear;
+      end;
+
+    procedure tlinkedlist.clear;
+
+      var
+         hp : plinkedlist_item;
+
+      begin
+         hp:=first;
+         while assigned(hp) do
+           begin
+              first:=hp^.next;
+              dispose(hp,done);
+              hp:=first;
+           end;
+      end;
+
+    procedure tlinkedlist.insertlist(p : plinkedlist);
+
+      begin
+         { empty list ? }
+         if not(assigned(p^.first)) then
+           exit;
+
+         p^.last^.next:=first;
+
+         { we have a double linked list }
+         if assigned(first) then
+           first^.last:=p^.last;
+
+         first:=p^.first;
+
+         if not(assigned(last)) then
+           last:=p^.last;
+
+         { p becomes empty }
+         p^.first:=nil;
+         p^.last:=nil;
+      end;
+
+    procedure tlinkedlist.concat(p : plinkedlist_item);
+
+      begin
+         p^.last:=nil;
+         p^.next:=nil;
+         if not(assigned(first)) then
+           first:=p
+           else
+             begin
+                last^.next:=p;
+                p^.last:=last;
+             end;
+         last:=p;
+      end;
+
+    procedure tlinkedlist.insert(p : plinkedlist_item);
+
+      begin
+         p^.last:=nil;
+         p^.next:=nil;
+         if not(assigned(first)) then
+           last:=p
+         else
+           begin
+              first^.last:=p;
+              p^.next:=first;
+              first:=p;
+           end;
+         first:=p;
+      end;
+
+    procedure tlinkedlist.remove(p : plinkedlist_item);
+
+      begin
+         if not(assigned(p)) then
+           exit;
+         if (first=p) and (last=p) then
+           begin
+              first:=nil;
+              last:=nil;
+           end
+         else if first=p then
+           begin
+              first:=p^.next;
+              if assigned(first) then
+                first^.last:=nil;
+           end
+         else if last=p then
+           begin
+              last:=last^.last;
+              if assigned(last) then
+                last^.next:=nil;
+           end
+         else
+           begin
+              p^.last^.next:=p^.next;
+              p^.next^.last:=p^.last;
+           end;
+         p^.next:=nil;
+         p^.last:=nil;
+      end;
+
+    procedure tlinkedlist.concatlist(p : plinkedlist);
+
+     begin
+         if not(assigned(p^.first)) then
+           exit;
+
+         if not(assigned(first)) then
+           first:=p^.first
+           else
+             begin
+                last^.next:=p^.first;
+                p^.first^.last:=last;
+             end;
+
+         last:=p^.last;
+
+         { make p empty }
+         p^.last:=nil;
+         p^.first:=nil;
+      end;
+
+{****************************************************************************
+                               TBUFFEREDFILE
+ ****************************************************************************}
+
+    Const
+       crcseed = $ffffffff;
+
+       crctable : array[0..255] of longint = (
+          $00000000,$77073096,$ee0e612c,$990951ba,$076dc419,$706af48f,
+          $e963a535,$9e6495a3,$0edb8832,$79dcb8a4,$e0d5e91e,$97d2d988,
+          $09b64c2b,$7eb17cbd,$e7b82d07,$90bf1d91,$1db71064,$6ab020f2,
+          $f3b97148,$84be41de,$1adad47d,$6ddde4eb,$f4d4b551,$83d385c7,
+          $136c9856,$646ba8c0,$fd62f97a,$8a65c9ec,$14015c4f,$63066cd9,
+          $fa0f3d63,$8d080df5,$3b6e20c8,$4c69105e,$d56041e4,$a2677172,
+          $3c03e4d1,$4b04d447,$d20d85fd,$a50ab56b,$35b5a8fa,$42b2986c,
+          $dbbbc9d6,$acbcf940,$32d86ce3,$45df5c75,$dcd60dcf,$abd13d59,
+          $26d930ac,$51de003a,$c8d75180,$bfd06116,$21b4f4b5,$56b3c423,
+          $cfba9599,$b8bda50f,$2802b89e,$5f058808,$c60cd9b2,$b10be924,
+          $2f6f7c87,$58684c11,$c1611dab,$b6662d3d,$76dc4190,$01db7106,
+          $98d220bc,$efd5102a,$71b18589,$06b6b51f,$9fbfe4a5,$e8b8d433,
+          $7807c9a2,$0f00f934,$9609a88e,$e10e9818,$7f6a0dbb,$086d3d2d,
+          $91646c97,$e6635c01,$6b6b51f4,$1c6c6162,$856530d8,$f262004e,
+          $6c0695ed,$1b01a57b,$8208f4c1,$f50fc457,$65b0d9c6,$12b7e950,
+          $8bbeb8ea,$fcb9887c,$62dd1ddf,$15da2d49,$8cd37cf3,$fbd44c65,
+          $4db26158,$3ab551ce,$a3bc0074,$d4bb30e2,$4adfa541,$3dd895d7,
+          $a4d1c46d,$d3d6f4fb,$4369e96a,$346ed9fc,$ad678846,$da60b8d0,
+          $44042d73,$33031de5,$aa0a4c5f,$dd0d7cc9,$5005713c,$270241aa,
+          $be0b1010,$c90c2086,$5768b525,$206f85b3,$b966d409,$ce61e49f,
+          $5edef90e,$29d9c998,$b0d09822,$c7d7a8b4,$59b33d17,$2eb40d81,
+          $b7bd5c3b,$c0ba6cad,$edb88320,$9abfb3b6,$03b6e20c,$74b1d29a,
+          $ead54739,$9dd277af,$04db2615,$73dc1683,$e3630b12,$94643b84,
+          $0d6d6a3e,$7a6a5aa8,$e40ecf0b,$9309ff9d,$0a00ae27,$7d079eb1,
+          $f00f9344,$8708a3d2,$1e01f268,$6906c2fe,$f762575d,$806567cb,
+          $196c3671,$6e6b06e7,$fed41b76,$89d32be0,$10da7a5a,$67dd4acc,
+          $f9b9df6f,$8ebeeff9,$17b7be43,$60b08ed5,$d6d6a3e8,$a1d1937e,
+          $38d8c2c4,$4fdff252,$d1bb67f1,$a6bc5767,$3fb506dd,$48b2364b,
+          $d80d2bda,$af0a1b4c,$36034af6,$41047a60,$df60efc3,$a867df55,
+          $316e8eef,$4669be79,$cb61b38c,$bc66831a,$256fd2a0,$5268e236,
+          $cc0c7795,$bb0b4703,$220216b9,$5505262f,$c5ba3bbe,$b2bd0b28,
+          $2bb45a92,$5cb36a04,$c2d7ffa7,$b5d0cf31,$2cd99e8b,$5bdeae1d,
+          $9b64c2b0,$ec63f226,$756aa39c,$026d930a,$9c0906a9,$eb0e363f,
+          $72076785,$05005713,$95bf4a82,$e2b87a14,$7bb12bae,$0cb61b38,
+          $92d28e9b,$e5d5be0d,$7cdcefb7,$0bdbdf21,$86d3d2d4,$f1d4e242,
+          $68ddb3f8,$1fda836e,$81be16cd,$f6b9265b,$6fb077e1,$18b74777,
+          $88085ae6,$ff0f6a70,$66063bca,$11010b5c,$8f659eff,$f862ae69,
+          $616bffd3,$166ccf45,$a00ae278,$d70dd2ee,$4e048354,$3903b3c2,
+          $a7672661,$d06016f7,$4969474d,$3e6e77db,$aed16a4a,$d9d65adc,
+          $40df0b66,$37d83bf0,$a9bcae53,$debb9ec5,$47b2cf7f,$30b5ffe9,
+          $bdbdf21c,$cabac28a,$53b39330,$24b4a3a6,$bad03605,$cdd70693,
+          $54de5729,$23d967bf,$b3667a2e,$c4614ab8,$5d681b02,$2a6f2b94,
+          $b40bbe37,$c30c8ea1,$5a05df1b,$2d02ef8d);
+
+    constructor tbufferedfile.init(const filename : string;_bufsize : longint);
+
+      begin
+         assign(f,filename);
+         bufsize:=_bufsize;
+         bufpos:=0;
+         buflast:=0;
+         do_crc:=false;
+         iomode:=0;
+         change_endian:=false;
+         clear_crc;
+      end;
+
+    destructor tbufferedfile.done;
+
+      begin
+         close;
+      end;
+
+    procedure tbufferedfile.clear_crc;
+
+      begin
+         crc:=crcseed;
+      end;
+
+    procedure tbufferedfile.setbuf(p : pchar;s : longint);
+
+      begin
+         flush;
+         freemem(buf,bufsize);
+         bufsize:=s;
+         buf:=p;
+      end;
+
+    procedure tbufferedfile.reset;
+
+      begin
+         iomode:=1;
+         getmem(buf,bufsize);
+         system.reset(f,1);
+      end;
+
+    procedure tbufferedfile.rewrite;
+
+      begin
+         iomode:=2;
+         getmem(buf,bufsize);
+         system.rewrite(f,1);
+      end;
+
+    procedure tbufferedfile.flush;
+
+      var
+{$ifdef FPC}
+         count : longint;
+{$else}
+         count : integer;
+{$endif}
+
+      begin
+         if iomode=2 then
+           begin
+              if bufpos=0 then
+                exit;
+              blockwrite(f,buf^,bufpos)
+           end
+         else if iomode=1 then
+            if buflast=bufpos then
+              begin
+                 blockread(f,buf^,bufsize,count);
+                 buflast:=count;
+              end;
+         bufpos:=0;
+      end;
+
+    function tbufferedfile.getftime : longint;
+
+      var
+         l : longint;
+{$ifdef linux}
+         Info : Stat;
+{$endif}
+      begin
+{$ifndef linux}
+         { this only works if the file is open !! }
+         dos.getftime(f,l);
+{$else}
+         Fstat(f,Info);
+         l:=info.mtime;
+{$endif}
+         getftime:=l;
+      end;
+
+    function tbufferedfile.getsize : longint;
+
+      begin
+        getsize:=filesize(f);
+      end;
+
+    procedure tbufferedfile.seek(l : longint);
+
+      begin
+         if iomode=2 then
+           begin
+              flush;
+              system.seek(f,l);
+           end
+         else if iomode=1 then
+           begin
+              { forces a reload }
+              bufpos:=buflast;
+              system.seek(f,l);
+              flush;
+           end;
+      end;
+
+    type
+{$ifdef tp}
+       bytearray1 = array [1..65535] of byte;
+{$else}
+       bytearray1 = array [1..10000000] of byte;
+{$endif}
+
+    procedure tbufferedfile.read_data(var data;bytes : longint;var count : longint);
+
+      var
+         p : pchar;
+         c,i : longint;
+
+      begin
+         p:=pchar(@data);
+         count:=0;
+         while bytes-count>0 do
+           begin
+              if bytes-count>buflast-bufpos then
+                begin
+                   move((buf+bufpos)^,(p+count)^,buflast-bufpos);
+                   inc(count,buflast-bufpos);
+                   bufpos:=buflast;
+                   flush;
+                   { can't we read anything ? }
+                   if bufpos=buflast then
+                     break;
+                end
+              else
+                begin
+                   move((buf+bufpos)^,(p+count)^,bytes-count);
+                   inc(bufpos,bytes-count);
+                   count:=bytes;
+                   break;
+                end;
+           end;
+         if do_crc then
+           begin
+              c:=crc;
+              for i:=1 to bytes do
+              c:=(c shr 8) xor crctable[byte(c) xor (bytearray1(data)[i])];
+              crc:=c;
+           end;
+      end;
+
+    procedure tbufferedfile.write_data(var data;count : longint);
+
+      var
+         c,i : longint;
+
+      begin
+         if bufpos+count>bufsize then
+           flush;
+         move(data,(buf+bufpos)^,count);
+         inc(bufpos,count);
+         if do_crc then
+           begin
+              c:=crc;
+              for i:=1 to count do
+                c:=(c shr 8) xor crctable[byte(c) xor (bytearray1(data)[i])];
+              crc:=c;
+           end;
+      end;
+
+    function tbufferedfile.getcrc : longint;
+
+      begin
+         getcrc:=crc xor crcseed;
+      end;
+
+    procedure tbufferedfile.write_string(const s : string);
+
+      begin
+        if bufpos+length(s)>bufsize then
+          flush;
+        move(s[1],(buf+bufpos)^,length(s));
+        inc(bufpos,length(s));
+      end;
+
+    procedure tbufferedfile.write_pchar(p : pchar);
+
+      var
+         l : longint;
+
+      begin
+        l:=strlen(p);
+        if l>=bufsize then
+          runerror(222);
+        if bufpos+l>bufsize then
+          flush;
+        move(p^,(buf+bufpos)^,l);
+        inc(bufpos,l);
+      end;
+
+    procedure tbufferedfile.write_byte(b : byte);
+
+      begin
+         write_data(b,sizeof(byte));
+      end;
+
+    procedure tbufferedfile.write_long(l : longint);
+
+      var
+         w1,w2 : word;
+
+      begin
+         if change_endian then
+           begin
+              w1:=l and $ffff;
+              w2:=l shr 16;
+              l:=swap(w2)+(longint(swap(w1)) shl 16);
+              write_data(l,sizeof(longint))
+           end
+         else
+           write_data(l,sizeof(longint))
+      end;
+
+    procedure tbufferedfile.write_word(w : word);
+
+      begin
+         if change_endian then
+           begin
+              w:=swap(w);
+              write_data(w,sizeof(word))
+           end
+         else
+           write_data(w,sizeof(word));
+      end;
+
+    procedure tbufferedfile.write_double(d : double);
+
+      begin
+         write_data(d,sizeof(double));
+      end;
+
+    function tbufferedfile.getpath : string;
+
+      begin
+{$ifdef dummy}
+         getpath:=strpas(filerec(f).name);
+{$endif}
+         getpath:='';
+      end;
+
+    procedure tbufferedfile.close;
+
+      begin
+         if iomode<>0 then
+           begin
+              flush;
+              system.close(f);
+              freemem(buf,bufsize);
+              iomode:=0;
+           end;
+      end;
+{$ifdef MAKELIB}
+    procedure tbufferedfile.changename(filename : string);
+
+      begin
+         close;
+         assign(f,filename);
+      end;
+{$endif MAKELIB}
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.15  1998/03/10 16:27:38  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.14  1998/03/10 01:17:18  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.13  1998/03/04 17:33:42  michael
+  + Changed ifdef FPK to ifdef FPC
+
+  Revision 1.12  1998/03/02 01:48:31  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.11  1998/02/28 00:20:22  florian
+    * more changes to get import libs for Win32 working
+
+  Revision 1.10  1998/02/24 14:20:50  peter
+    + tstringcontainer.empty
+    * ld -T option restored for linux
+    * libraries are placed before the objectfiles in a .PPU file
+    * removed 'uses link' from files.pas
+
+  Revision 1.9  1998/02/18 13:48:17  michael
+  + Implemented an OS independent AsmRes object.
+
+  Revision 1.8  1998/02/17 21:20:45  peter
+    + Script unit
+    + __EXIT is called again to exit a program
+    - target_info.link/assembler calls
+    * linking works again for dos
+    * optimized a few filehandling functions
+    * fixed stabs generation for procedures
+
+  Revision 1.7  1998/02/13 10:34:55  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.6  1998/02/12 11:50:01  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.5  1998/02/06 23:08:32  florian
+    + endian to targetinfo and sourceinfo added
+    + endian independed writing of ppu file (reading missed), a PPU file
+      is written with the target endian
+
+  Revision 1.4  1998/01/13 17:11:34  michael
+  * Changed getftime method to work faster under linux.
+
+  Revision 1.3  1997/12/05 13:45:34  daniel
+  - Removed overlay init. This is done by PPOVIN.PAS.
+
+  Revision 1.2  1997/11/28 18:14:28  pierre
+   working version with several bug fixes
+
+  Revision 1.1.1.1  1997/11/27 08:32:55  michael
+  FPC Compiler CVS start
+
+ Pre-CVS log:
+
+ History:
+      30th september 1996:
+         + english comments (FK)
+         + _2pchar renamed to pstring2pchar (FK)
+         + _2pstring renamed to pchar2pstring (FK)
+      15th october 1996:
+         + tstringcontainer is compilable (FK)
+         + full compilable (FK)
+       4th january 1996:
+         + tstring_item added (FK)
+      19th november 1997:
+         + call of overlay init (FK)
+}

compiler/cws.txt

@@ -0,0 +1,11 @@
+Compiler Writer's Guide
+-----------------------
+Here are a few tips for changing things in the compiler:
+(by FK mostly)
+
+  - Assigned should be used instead of checking for nil directly, as 
+it can help solving pointer problems when in real mode.
+  - All compiler files should be saved in UNIX format
+ 
+
+

compiler/depend

@@ -0,0 +1,468 @@
+pp: pp.pas \
+	cobjects.ppu \
+	globals.ppu \
+	parser.ppu \
+	systems.ppu \
+	tree.ppu \
+	symtable.ppu \
+	options.ppu \
+	link.ppu \
+	import.ppu \
+	files.ppu \
+	verb_def.ppu \
+	verbose.ppu
+
+cobjects.ppu: cobjects.pas
+
+globals.ppu: globals.pas \
+	cobjects.ppu \
+	systems.ppu
+
+systems.ppu: systems.pas
+
+parser.ppu: parser.pas \
+	cobjects.ppu \
+	globals.ppu \
+	scanner.ppu \
+	systems.ppu \
+	symtable.ppu \
+	tree.ppu \
+	aasm.ppu \
+	types.ppu \
+	pass_1.ppu \
+	hcodegen.ppu \
+	files.ppu \
+	verbose.ppu \
+	script.ppu \
+	import.ppu \
+	i386.ppu \
+	cgi386.ppu \
+	cgai386.ppu \
+	tgeni386.ppu \
+	aopt386.ppu \
+	pbase.ppu \
+	pmodules.ppu \
+	pdecl.ppu \
+	assemble.ppu \
+	link.ppu
+
+scanner.ppu: scanner.pas \
+	cobjects.ppu \
+	globals.ppu \
+	symtable.ppu \
+	systems.ppu \
+	files.ppu \
+	verbose.ppu \
+	link.ppu
+
+symtable.ppu: symtable.pas \
+	cobjects.ppu \
+	verbose.ppu \
+	systems.ppu \
+	globals.ppu \
+	aasm.ppu \
+	files.ppu \
+	link.ppu \
+	i386.ppu \
+	gdb.ppu
+
+verbose.ppu: verbose.pas \
+	messages.ppu \
+	globals.ppu
+
+messages.ppu: messages.pas
+
+aasm.ppu: aasm.pas \
+	cobjects.ppu \
+	files.ppu \
+	globals.ppu \
+	verbose.ppu
+
+files.ppu: files.pas \
+	cobjects.ppu \
+	globals.ppu \
+	verbose.ppu \
+	systems.ppu
+
+link.ppu: link.pas \
+	cobjects.ppu \
+	script.ppu \
+	globals.ppu \
+	systems.ppu \
+	verbose.ppu
+
+script.ppu: script.pas \
+	cobjects.ppu \
+	globals.ppu \
+	systems.ppu
+
+i386.ppu: i386.pas \
+	systems.ppu \
+	cobjects.ppu \
+	globals.ppu \
+	aasm.ppu \
+	files.ppu \
+	verbose.ppu
+
+gdb.ppu: gdb.pas \
+	i386.ppu \
+	cobjects.ppu \
+	globals.ppu \
+	aasm.ppu
+
+tree.ppu: tree.pas \
+	globals.ppu \
+	symtable.ppu \
+	cobjects.ppu \
+	verbose.ppu \
+	aasm.ppu \
+	files.ppu \
+	i386.ppu
+
+types.ppu: types.pas \
+	cobjects.ppu \
+	globals.ppu \
+	symtable.ppu \
+	tree.ppu \
+	aasm.ppu \
+	verbose.ppu
+
+pass_1.ppu: pass_1.pas \
+	tree.ppu \
+	cobjects.ppu \
+	verbose.ppu \
+	systems.ppu \
+	globals.ppu \
+	aasm.ppu \
+	symtable.ppu \
+	types.ppu \
+	hcodegen.ppu \
+	files.ppu \
+	i386.ppu \
+	tgeni386.ppu
+
+hcodegen.ppu: hcodegen.pas \
+	cobjects.ppu \
+	systems.ppu \
+	globals.ppu \
+	tree.ppu \
+	symtable.ppu \
+	types.ppu \
+	aasm.ppu \
+	i386.ppu
+
+tgeni386.ppu: tgeni386.pas \
+	cobjects.ppu \
+	globals.ppu \
+	tree.ppu \
+	hcodegen.ppu \
+	verbose.ppu \
+	files.ppu \
+	aasm.ppu \
+	i386.ppu
+
+import.ppu: import.pas \
+	systems.ppu \
+	verbose.ppu \
+	os2_targ.ppu \
+	win_targ.ppu
+
+os2_targ.ppu: os2_targ.pas \
+	import.ppu \
+	globals.ppu \
+	link.ppu \
+	files.ppu
+
+win_targ.ppu: win_targ.pas \
+	import.ppu \
+	aasm.ppu \
+	files.ppu \
+	globals.ppu \
+	cobjects.ppu \
+	i386.ppu
+
+cgi386.ppu: cgi386.pas \
+	verbose.ppu \
+	cobjects.ppu \
+	systems.ppu \
+	globals.ppu \
+	tree.ppu \
+	symtable.ppu \
+	types.ppu \
+	pass_1.ppu \
+	hcodegen.ppu \
+	aasm.ppu \
+	i386.ppu \
+	tgeni386.ppu \
+	files.ppu \
+	cgai386.ppu \
+	gdb.ppu
+
+cgai386.ppu: cgai386.pas \
+	cobjects.ppu \
+	systems.ppu \
+	globals.ppu \
+	tree.ppu \
+	symtable.ppu \
+	types.ppu \
+	pass_1.ppu \
+	hcodegen.ppu \
+	aasm.ppu \
+	i386.ppu \
+	tgeni386.ppu \
+	files.ppu \
+	verbose.ppu \
+	gdb.ppu
+
+aopt386.ppu: aopt386.pas \
+	aasm.ppu \
+	cobjects.ppu \
+	globals.ppu \
+	symtable.ppu \
+	verbose.ppu \
+	i386.ppu \
+	cgi386.ppu
+
+pbase.ppu: pbase.pas \
+	cobjects.ppu \
+	globals.ppu \
+	scanner.ppu \
+	symtable.ppu \
+	systems.ppu \
+	verbose.ppu
+
+pmodules.ppu: pmodules.pas \
+	cobjects.ppu \
+	globals.ppu \
+	scanner.ppu \
+	symtable.ppu \
+	aasm.ppu \
+	tree.ppu \
+	pass_1.ppu \
+	types.ppu \
+	hcodegen.ppu \
+	files.ppu \
+	verbose.ppu \
+	systems.ppu \
+	link.ppu \
+	assemble.ppu \
+	gdb.ppu \
+	pbase.ppu \
+	pdecl.ppu \
+	pstatmnt.ppu \
+	psub.ppu \
+	i386.ppu \
+	cgai386.ppu \
+	tgeni386.ppu \
+	cgi386.ppu \
+	aopt386.ppu \
+	parser.ppu
+
+assemble.ppu: assemble.pas \
+	cobjects.ppu \
+	globals.ppu \
+	aasm.ppu \
+	script.ppu \
+	files.ppu \
+	systems.ppu \
+	verbose.ppu \
+	ag386att.ppu \
+	ag386int.ppu
+
+ag386att.ppu: ag386att.pas \
+	aasm.ppu \
+	assemble.ppu \
+	globals.ppu \
+	systems.ppu \
+	cobjects.ppu \
+	i386.ppu \
+	files.ppu \
+	verbose.ppu \
+	gdb.ppu
+
+ag386int.ppu: ag386int.pas \
+	aasm.ppu \
+	assemble.ppu \
+	globals.ppu \
+	systems.ppu \
+	cobjects.ppu \
+	i386.ppu \
+	files.ppu \
+	verbose.ppu \
+	gdb.ppu
+
+pdecl.ppu: pdecl.pas \
+	globals.ppu \
+	symtable.ppu \
+	cobjects.ppu \
+	scanner.ppu \
+	aasm.ppu \
+	tree.ppu \
+	pass_1.ppu \
+	types.ppu \
+	hcodegen.ppu \
+	verbose.ppu \
+	gdb.ppu \
+	pbase.ppu \
+	ptconst.ppu \
+	pexpr.ppu \
+	psub.ppu \
+	pexports.ppu \
+	i386.ppu
+
+ptconst.ppu: ptconst.pas \
+	symtable.ppu \
+	cobjects.ppu \
+	globals.ppu \
+	scanner.ppu \
+	aasm.ppu \
+	tree.ppu \
+	pass_1.ppu \
+	hcodegen.ppu \
+	types.ppu \
+	verbose.ppu \
+	pbase.ppu \
+	pexpr.ppu \
+	i386.ppu
+
+pexpr.ppu: pexpr.pas \
+	symtable.ppu \
+	tree.ppu \
+	cobjects.ppu \
+	globals.ppu \
+	scanner.ppu \
+	aasm.ppu \
+	pass_1.ppu \
+	hcodegen.ppu \
+	types.ppu \
+	verbose.ppu \
+	pbase.ppu \
+	pdecl.ppu \
+	i386.ppu
+
+psub.ppu: psub.pas \
+	cobjects.ppu \
+	globals.ppu \
+	scanner.ppu \
+	symtable.ppu \
+	aasm.ppu \
+	tree.ppu \
+	pass_1.ppu \
+	types.ppu \
+	hcodegen.ppu \
+	files.ppu \
+	verbose.ppu \
+	systems.ppu \
+	link.ppu \
+	import.ppu \
+	gdb.ppu \
+	pbase.ppu \
+	ptconst.ppu \
+	pdecl.ppu \
+	pexpr.ppu \
+	pstatmnt.ppu \
+	i386.ppu \
+	cgai386.ppu \
+	tgeni386.ppu \
+	cgi386.ppu \
+	aopt386.ppu
+
+pstatmnt.ppu: pstatmnt.pas \
+	tree.ppu \
+	cobjects.ppu \
+	scanner.ppu \
+	globals.ppu \
+	symtable.ppu \
+	aasm.ppu \
+	pass_1.ppu \
+	types.ppu \
+	hcodegen.ppu \
+	files.ppu \
+	verbose.ppu \
+	i386.ppu \
+	rai386.ppu \
+	ratti386.ppu \
+	radi386.ppu \
+	tgeni386.ppu \
+	pbase.ppu \
+	pexpr.ppu \
+	pdecl.ppu
+
+rai386.ppu: rai386.pas \
+	tree.ppu \
+	i386.ppu \
+	aasm.ppu \
+	globals.ppu \
+	asmutils.ppu \
+	hcodegen.ppu \
+	scanner.ppu \
+	cobjects.ppu \
+	verbose.ppu
+
+asmutils.ppu: asmutils.pas \
+	symtable.ppu \
+	aasm.ppu \
+	hcodegen.ppu \
+	verbose.ppu \
+	systems.ppu \
+	globals.ppu \
+	files.ppu \
+	cobjects.ppu \
+	i386.ppu
+
+ratti386.ppu: ratti386.pas \
+	i386.ppu \
+	tree.ppu \
+	aasm.ppu \
+	globals.ppu \
+	asmutils.ppu \
+	hcodegen.ppu \
+	scanner.ppu \
+	cobjects.ppu \
+	verbose.ppu \
+	symtable.ppu
+
+radi386.ppu: radi386.pas \
+	tree.ppu \
+	i386.ppu \
+	hcodegen.ppu \
+	globals.ppu \
+	scanner.ppu \
+	aasm.ppu \
+	cobjects.ppu \
+	symtable.ppu \
+	types.ppu \
+	verbose.ppu \
+	asmutils.ppu
+
+pexports.ppu: pexports.pas \
+	cobjects.ppu \
+	globals.ppu \
+	scanner.ppu \
+	symtable.ppu \
+	pbase.ppu \
+	verbose.ppu
+
+options.ppu: options.pas \
+	cobjects.ppu \
+	globals.ppu \
+	systems.ppu \
+	verbose.ppu \
+	scanner.ppu \
+	link.ppu \
+	verb_def.ppu \
+	messages.ppu \
+	os2_targ.ppu \
+	opts386.ppu
+
+verb_def.ppu: verb_def.pas \
+	verbose.ppu \
+	cobjects.ppu \
+	systems.ppu \
+	globals.ppu \
+	files.ppu
+
+opts386.ppu: opts386.pas \
+	options.ppu \
+	globals.ppu
+

compiler/files.pas

@@ -0,0 +1,893 @@
+{
+    $Id$
+    Copyright (c) 1996-98 by Florian Klaempfl
+
+    This unit implements an extended file management and the first loading
+    and searching of the modules (ppufiles)
+
+    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 files;
+
+  interface
+
+    uses
+       cobjects,globals;
+
+    const
+{$ifdef FPC}
+       maxunits = 1024;
+{$else}
+       maxunits = 128;
+{$endif}
+
+    type
+       pextfile = ^textfile;
+
+       { this isn't a text file, this is t-ext-file }
+       { which means a extended file                }
+       { this files can be handled by a file        }
+       { manager                                    }
+       textfile = object(tbufferedfile)
+          path,name,ext : pstring;
+          { this is because there is a name conflict }
+          { with the older next from tinputstack     }
+          _next : pextfile;
+          { 65000 input files for a unit should be enough !! }
+          ref_index : word;
+
+          { p must be the complete path (with ending \ (or / for unix ...) }
+          constructor init(const p,n,e : string);
+          destructor done;virtual;
+       end;
+
+       pinputfile = ^tinputfile;
+
+       tinputfile = object(textfile)
+          filenotatend : boolean;
+          line_no : longint;
+          { second counter for unimportant tokens }
+          line_count : longint;
+          { next input file in the stack of input files }
+          next : pinputfile;
+          { to handle the browser refs }
+          ref_count : longint;
+
+          constructor init(const p,n,e : string);
+          { writes the file name and line number to t }
+          procedure write_file_line(var t : text);
+          function get_file_line : string;
+       end;
+
+       pfilemanager = ^tfilemanager;
+
+       tfilemanager = object
+          files : pextfile;
+          last_ref_index : word;
+          constructor init;
+          destructor done;
+          procedure close_all;
+          procedure register_file(f : pextfile);
+       end;
+
+       pimported_procedure = ^timported_procedure;
+
+       timported_procedure = object(tlinkedlist_item)
+          ordnr : word;
+          name,func : pstring;
+          { should be plabel, but this gaves problems with circular units }
+          lab : pointer;
+          constructor init(const n,s : string;o : word);
+          destructor done;virtual;
+       end;
+
+       pimportlist = ^timportlist;
+
+       timportlist = object(tlinkedlist_item)
+          dllname : pstring;
+          imported_procedures : plinkedlist;
+          constructor init(const n : string);
+          destructor done;virtual;
+       end;
+
+    type
+       pmodule = ^tmodule;
+       pused_unit = ^tused_unit;
+
+       tused_unit = object(tlinkedlist_item)
+          u : pmodule;
+          in_uses, in_interface, is_stab_written : boolean;
+          unitid : word;
+          constructor init(_u : pmodule;f : byte);
+          destructor done;virtual;
+       end;
+
+       tunitmap = array[0..maxunits-1] of pointer;
+       punitmap = ^tunitmap;
+
+       tmodule = object(tlinkedlist_item)
+
+          { the PPU file }
+          ppufile : pextfile;
+          { used for global switches - in_main section after uses clause }
+          { then TRUE else false.                                        }
+          in_main : boolean;
+          { mapping of all used units }
+          map : punitmap;
+          { local unit counter }
+          unitcount : word;
+          { this is a pointer because symtable uses this unit }
+          { it should be psymtable                            }
+          symtable : pointer;
+
+          { PPU version, handle different versions }
+          ppuversion : longint;
+
+          { check sum written to the file }
+          crc : longint;
+
+          { flags }
+          flags : byte;
+
+          {Set if the module imports from DLL's.}
+          uses_imports:boolean;
+
+          imports : plinkedlist;
+
+          { how to write this file }
+          output_format : tof;
+
+          { for interpenetrated units }
+          in_implementation,
+          compiled,
+          do_assemble,
+          do_compile,              { true, if it's needed to compile the sources }
+          sources_avail : boolean; { true, if all sources are reachable }
+
+          { only used, if the module is compiled by this compiler call }
+          sourcefiles : tfilemanager;
+          linklibfiles,
+          linkofiles  : tstringcontainer;
+          used_units  : tlinkedlist;
+          current_inputfile : pinputfile;
+
+          unitname,               { name of the (unit) module }
+          objfilename,            { fullname of the objectfile }
+          asmfilename,            { fullname of the assemblerfile }
+          ppufilename,            { fullname of the ppufile }
+          mainsource   : pstring; { name of the main sourcefile }
+
+          constructor init(const s:string;is_unit:boolean);
+          { this is to be called only when compiling again }
+          destructor special_done;virtual;
+
+          function load_ppu(const unit_path,n,ext : string):boolean;
+          procedure search_unit(const n : string);
+       end;
+
+    const
+       main_module : pmodule = nil;
+       current_module : pmodule = nil;
+
+    var
+       loaded_units : tlinkedlist;
+
+    type
+       tunitheader = array[0..19] of char;
+
+    const
+                                   {                compiler version }
+                                   {             format      |       }
+                                   { signature    |          |       }
+                                   {  |           |          |       }
+                                   { /-------\   /-------\  /----\   }
+       unitheader : tunitheader  = ('P','P','U','0','1','3',#0,#99,
+                                     #0,#0,#0,#0,#0,#0,#255,#255,
+                                   { |   | \---------/ \-------/    }
+                                   { |   |    |             |        }
+                                   { |   |    check sum     |        }
+                                   { |   \--flags        unused      }
+                                   { target system                   }
+                                    #0,#0,#0,#0);
+                                   {\---------/                      }
+                                   {  |                              }
+                                   {  start of machine language      }
+
+    const
+       ibloadunit = 1;
+       iborddef = 2;
+       ibpointerdef = 3;
+       ibtypesym = 4;
+       ibarraydef = 5;
+       ibprocdef = 6;
+       ibprocsym = 7;
+       iblinkofile = 8;
+       ibstringdef = 9;
+       ibvarsym = 10;
+       ibconstsym = 11;
+       ibinitunit = 12;
+       ibaufzaehlsym = 13;
+       ibtypedconstsym = 14;
+       ibrecorddef = 15;
+       ibfiledef = 16;
+       ibformaldef = 17;
+       ibobjectdef = 18;
+       ibenumdef = 19;
+       ibsetdef = 20;
+       ibprocvardef = 21;
+       ibsourcefile = 22;
+       ibdbxcount = 23;
+       ibfloatdef = 24;
+       ibref = 25;
+       ibextsymref = 26;
+       ibextdefref = 27;
+       ibabsolutesym = 28;
+       ibclassrefdef = 29;
+       ibpropertysym = 30;
+       iblibraries = 31;
+       iblongstringdef = 32;
+       ibansistringdef = 33;
+       ibend = 255;
+
+       { unit flags }
+       uf_init = 1;
+       uf_uses_dbx = 2;
+       uf_uses_browser = 4;
+       uf_in_library = 8;
+       uf_shared_library = 16;
+       uf_big_endian = 32;
+
+  implementation
+
+  uses
+    dos,verbose,systems;
+
+
+{****************************************************************************
+                                  TFILE
+ ****************************************************************************}
+
+    constructor textfile.init(const p,n,e : string);
+
+      begin
+{$ifdef FPC}
+         inherited init(p+n+e,65536);
+{$else}
+         inherited init(p+n+e,10000);
+{$endif}
+         path:=stringdup(p);
+         name:=stringdup(n);
+         ext:=stringdup(e);
+      end;
+
+    destructor textfile.done;
+
+      begin
+         inherited done;
+      end;
+
+{****************************************************************************
+                                  TINPUTFILE
+ ****************************************************************************}
+
+    constructor tinputfile.init(const p,n,e : string);
+
+      begin
+         inherited init(p,n,e);
+         filenotatend:=true;
+         line_no:=1;
+         line_count:=0;
+         next:=nil;
+      end;
+
+    procedure tinputfile.write_file_line(var t : text);
+
+      begin
+         write(t,get_file_line);
+      end;
+
+    function tinputfile.get_file_line : string;
+
+      begin
+{$ifdef USE_RHIDE}
+        get_file_line:=lowercase(name^+ext^)+':'+tostr(line_no)+':'
+{$else  USE_RHIDE}
+        get_file_line:=name^+ext^+'('+tostr(line_no)+')'
+{$endif USE_RHIDE}
+      end;
+
+{****************************************************************************
+                                TFILEMANAGER
+ ****************************************************************************}
+
+    constructor tfilemanager.init;
+
+      begin
+         files:=nil;
+         last_ref_index:=0;
+      end;
+
+    destructor tfilemanager.done;
+
+      var
+         hp : pextfile;
+
+      begin
+         hp:=files;
+         while assigned(hp) do
+           begin
+              files:=files^._next;
+              dispose(hp,done);
+              hp:=files;
+           end;
+      end;
+
+    procedure tfilemanager.close_all;
+
+      begin
+      end;
+
+    procedure tfilemanager.register_file(f : pextfile);
+
+      begin
+         inc(last_ref_index);
+         f^._next:=files;
+         f^.ref_index:=last_ref_index;
+         files:=f;
+      end;
+
+{****************************************************************************
+                           Imports stuff
+ ****************************************************************************}
+
+
+    constructor timported_procedure.init(const n,s : string;o : word);
+
+      begin
+         inherited init;
+         func:=stringdup(n);
+         name:=stringdup(s);
+         ordnr:=o;
+         lab:=nil;
+      end;
+
+    destructor timported_procedure.done;
+
+      begin
+         stringdispose(name);
+         inherited done;
+      end;
+
+    constructor timportlist.init(const n : string);
+
+      begin
+         inherited init;
+         dllname:=stringdup(n);
+         imported_procedures:=new(plinkedlist,init);
+      end;
+
+    destructor timportlist.done;
+
+      begin
+         dispose(imported_procedures,done);
+         stringdispose(dllname);
+      end;
+
+{****************************************************************************
+                                  TMODULE
+ ****************************************************************************}
+
+{$I-}
+
+    function tmodule.load_ppu(const unit_path,n,ext : string):boolean;
+    var
+         header  : tunitheader;
+         count   : longint;
+         temp,hs : string;
+         b       : byte;
+         code    : word;
+         objfiletime,
+         ppufiletime,
+         asmfiletime,
+         source_time : longint;
+{$ifdef UseBrowser}
+         hp : pextfile;
+         _d : dirstr;
+         _n : namestr;
+         _e : extstr;
+{$endif UseBrowser}
+
+    begin
+      load_ppu:=false;
+
+      Message1(unit_u_ppu_loading,ppufilename^);
+      ppufile:=new(pextfile,init(unit_path,n,ext));
+      ppufile^.reset;
+      ppufile^.flush;
+
+      {Get ppufile time}
+      ppufiletime:=getnamedfiletime(ppufilename^);
+      Message1(unit_d_ppu_time,filetimestring(ppufiletime));
+
+      { load the header }
+      ppufile^.read_data(header,sizeof(header),count);
+      if count<>sizeof(header) then
+       begin
+         ppufile^.done;
+         Message(unit_d_ppu_file_too_short);
+         exit;
+       end;
+
+      { check for a valid PPU file }
+      if (header[0]<>'P') or (header[1]<>'P') or (header[2]<>'U') then
+       begin
+         ppufile^.done;
+         Message(unit_d_ppu_invalid_header);
+         exit;
+       end;
+
+      { load ppu version }
+      val(header[3]+header[4]+header[5],ppuversion,code);
+      if ppuversion<>13 then
+       begin
+         ppufile^.done;
+         Message1(unit_d_ppu_invalid_version,tostr(ppuversion));
+         exit;
+       end;
+
+      flags:=byte(header[9]);
+      Message1(unit_d_ppu_flags,tostr(flags));
+
+      crc:=plongint(@header[10])^;
+      Message1(unit_d_ppu_crc,tostr(crc));
+
+    { search source files there is at least one source file }
+      do_compile:=false;
+      sources_avail:=true;
+      ppufile^.read_data(b,1,count);
+      while b<>ibend do
+       begin
+         ppufile^.read_data(hs[0],1,count);
+         ppufile^.read_data(hs[1],ord(hs[0]),count);
+         if (flags and uf_in_library)<>0 then
+          begin
+            sources_avail:=false;
+            temp:=' library';
+          end
+         else
+          begin
+            { check the date of the source files }
+            Source_Time:=GetNamedFileTime(unit_path+hs);
+            if Source_Time=-1 then
+             begin
+               sources_avail:=false;
+               temp:=' not found';
+             end
+            else
+             begin
+               temp:=' time '+filetimestring(source_time);
+               if (source_time>ppufiletime) then
+                begin
+                  do_compile:=true;
+                  temp:=temp+' *'
+                end;
+             end;
+          end;
+         Message1(unit_t_ppu_source,unit_path+hs+temp);
+{$ifdef UseBrowser}
+         fsplit(unit_path+hs,_d,_n,_e);
+         new(hp,init(_d,_n,_e));
+         { the indexing should match what is done in writeasunit }
+         sourcefiles.register_file(hp);
+{$endif UseBrowser}
+         ppufile^.read_data(b,1,count);
+       end;
+    { main source is always the last }
+      stringdispose(mainsource);
+      mainsource:=stringdup(ppufile^.path^+hs);
+
+    { check the object and assembler file if not a library }
+      if (flags and uf_in_library)=0 then
+       begin
+       { the objectfile should be newer than the ppu file }
+         objfiletime:=getnamedfiletime(objfilename^);
+         if (ppufiletime<0) or (objfiletime<0) or (ppufiletime>objfiletime) then
+          begin
+          { check if assembler file is older than ppu file }
+            asmfileTime:=GetNamedFileTime(asmfilename^);
+            if (asmfiletime<0) or (ppufiletime>asmfiletime) then
+             begin
+               Message(unit_d_obj_and_asm_are_older_than_ppu);
+               do_compile:=true;
+             end
+            else
+             begin
+               Message(unit_d_obj_is_older_than_asm);
+               do_assemble:=true;
+             end;
+          end;
+       end;
+      load_ppu:=true;
+    end;
+
+    procedure tmodule.search_unit(const n : string);
+      var
+         ext       : string[8];
+         singlepathstring,
+         Path,
+         filename  : string;
+         found     : boolean;
+         start,pos : longint;
+
+         Function UnitExists(const ext:string):boolean;
+         begin
+           Message1(unit_t_unitsearch,Singlepathstring+filename+ext);
+           UnitExists:=FileExists(Singlepathstring+FileName+ext);
+         end;
+
+         Procedure SetFileNames;
+         begin
+           stringdispose(mainsource);
+           stringdispose(objfilename);
+           stringdispose(asmfilename);
+           stringdispose(ppufilename);
+           mainsource:=stringdup(SinglePathString+FileName+ext);
+           objfilename:=stringdup(SinglePathString+FileName+target_info.objext);
+           asmfilename:=stringdup(SinglePathString+FileName+target_info.asmext);
+           ppufilename:=stringdup(SinglePathString+FileName+target_info.unitext);
+         end;
+
+
+       begin
+         start:=1;
+         filename:=FixFileName(n);
+         path:=UnitSearchPath;
+         Found:=false;
+         repeat
+         {Create current path to check}
+           pos:=system.pos(';',path);
+           if pos=0 then
+            pos:=length(path)+1;
+           singlepathstring:=FixPath(copy(path,start,pos-start));
+           delete(path,start,pos-start+1);
+         { Check for PPL file }
+           if not (cs_link_static in aktswitches) then
+            begin
+              Found:=UnitExists(target_info.libext);
+              if Found then
+               Begin
+                 SetFileNames;
+                 Found:=Load_PPU(singlepathstring,filename,target_info.libext);
+               End;
+
+             end;
+         { Check for PPU file }
+           if not (cs_link_dynamic in aktswitches) and not Found then
+            begin
+              Found:=UnitExists(target_info.unitext);
+              if Found then
+               Begin
+                 SetFileNames;
+                 Found:=Load_PPU(singlepathstring,filename,target_info.unitext);
+               End;
+
+            end;
+         { Check for Sources }
+           if not Found then
+            begin
+              ppufile:=nil;
+              do_compile:=true;
+            {Check for .pp file}
+              Found:=UnitExists(target_info.sourceext);
+              if Found then
+               Ext:=target_info.sourceext
+              else
+               begin
+               {Check for .pas}
+                 Found:=UnitExists(target_info.pasext);
+                 if Found then
+                  Ext:=target_info.pasext;
+               end;
+              if Found then
+               begin
+                 sources_avail:=true;
+               {Load Filenames when found}
+                 SetFilenames;
+               end
+              else
+               begin
+                 sources_avail:=false;
+                 stringdispose(mainsource);
+               end;
+            end;
+         until Found or (path='');
+      end;
+
+    constructor tmodule.init(const s:string;is_unit:boolean);
+      var
+        p:dirstr;
+        n:namestr;
+        e:extstr;
+      begin
+         FSplit(s,p,n,e);
+         n:=Upper(n);
+         unitname:=stringdup(n);
+         objfilename:=nil;
+         asmfilename:=nil;
+         ppufilename:=nil;
+         mainsource:=stringdup(s);
+         used_units.init;
+         sourcefiles.init;
+         linkofiles.init;
+         linklibfiles.init;
+         ppufile:=nil;
+         current_inputfile:=nil;
+         map:=nil;
+         symtable:=nil;
+         flags:=0;
+         unitcount:=1;
+         do_assemble:=false;
+         do_compile:=false;
+         sources_avail:=true;
+         compiled:=false;
+         in_implementation:=false;
+         in_main:=false;
+         uses_imports:=false;
+         imports:=new(plinkedlist,init);
+         output_format:=commandline_output_format;
+       { search the PPU file if it is an unit }
+         if is_unit then
+          search_unit(unitname^);
+      end;
+
+    destructor tmodule.special_done;
+
+      begin
+         if assigned(map) then dispose(map);
+         { cannot remove that because it is linked
+         in the global chain of used_objects
+         used_units.done; }
+         sourcefiles.done;
+         linkofiles.done;
+         linklibfiles.done;
+         if assigned(ppufile) then
+          dispose(ppufile,done);
+         if assigned(imports) then
+           dispose(imports,done);
+         inherited done;
+      end;
+
+{****************************************************************************
+                              TUSED_UNIT
+ ****************************************************************************}
+
+
+    constructor tused_unit.init(_u : pmodule;f : byte);
+
+      begin
+         u:=_u;
+         in_interface:=false;
+         in_uses:=false;
+         is_stab_written:=false;
+         unitid:=f;
+      end;
+
+    destructor tused_unit.done;
+
+      begin
+         inherited done;
+      end;
+{$I+}
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:12  root
+  Initial revision
+
+  Revision 1.37  1998/03/13 22:45:58  florian
+    * small bug fixes applied
+
+  Revision 1.36  1998/03/11 22:22:52  florian
+    * Fixed circular unit uses, when the units are not in the current dir (from Peter)
+    * -i shows correct info, not <lf> anymore (from Peter)
+    * linking with shared libs works again (from Peter)
+
+  Revision 1.35  1998/03/10 16:27:38  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.34  1998/03/10 01:17:18  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.33  1998/03/04 17:33:44  michael
+  + Changed ifdef FPK to ifdef FPC
+
+  Revision 1.32  1998/03/04 01:35:03  peter
+    * messages for unit-handling and assembler/linker
+    * the compiler compiles without -dGDB, but doesn't work yet
+    + -vh for Hint
+
+  Revision 1.31  1998/02/28 14:43:47  florian
+    * final implemenation of win32 imports
+    * extended tai_align to allow 8 and 16 byte aligns
+
+  Revision 1.30  1998/02/28 09:30:57  florian
+    + writing of win32 import section added
+
+  Revision 1.29  1998/02/28 00:20:23  florian
+    * more changes to get import libs for Win32 working
+
+  Revision 1.28  1998/02/26 11:57:06  daniel
+  * New assembler optimizations commented out, because of bugs.
+  * Use of dir-/name- and extstr.
+
+  Revision 1.27  1998/02/24 14:20:51  peter
+    + tstringcontainer.empty
+    * ld -T option restored for linux
+    * libraries are placed before the objectfiles in a .PPU file
+    * removed 'uses link' from files.pas
+
+  Revision 1.26  1998/02/24 10:29:13  peter
+    * -a works again
+
+  Revision 1.25  1998/02/24 00:19:09  peter
+    * makefile works again (btw. linux does like any char after a \ )
+    * removed circular unit with assemble and files
+    * fixed a sigsegv in pexpr
+    * pmodule init unit/program is the almost the same, merged them
+
+  Revision 1.24  1998/02/22 23:03:17  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.23  1998/02/17 21:20:48  peter
+    + Script unit
+    + __EXIT is called again to exit a program
+    - target_info.link/assembler calls
+    * linking works again for dos
+    * optimized a few filehandling functions
+    * fixed stabs generation for procedures
+
+  Revision 1.22  1998/02/16 12:51:30  michael
+  + Implemented linker object
+
+  Revision 1.21  1998/02/13 10:34:58  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.20  1998/02/12 11:50:04  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.19  1998/02/06 23:08:33  florian
+    + endian to targetinfo and sourceinfo added
+    + endian independed writing of ppu file (reading missed), a PPU file
+      is written with the target endian
+
+  Revision 1.18  1998/02/02 13:13:27  pierre
+    * line_count transfered to tinputfile, to avoid crosscounting
+
+  Revision 1.17  1998/01/30 17:31:20  pierre
+    * bug of cyclic symtablestack fixed
+
+  Revision 1.16  1998/01/26 18:51:18  peter
+    * ForceSlash() changed to FixPath() which also removes a trailing './'
+
+  Revision 1.15  1998/01/23 17:12:11  pierre
+    * added some improvements for as and ld :
+      - doserror and dosexitcode treated separately
+      - PATH searched if doserror=2
+    + start of long and ansi string (far from complete)
+      in conditionnal UseLongString and UseAnsiString
+    * options.pas cleaned (some variables shifted to globals)gl
+
+  Revision 1.14  1998/01/22 08:57:54  peter
+    + added target_info.pasext and target_info.libext
+
+  Revision 1.13  1998/01/21 00:11:35  peter
+    * files in a ppl will now not recompile
+    * better info about source files of a ppu, a * after the time will
+      indicate that the file is changed
+
+  Revision 1.12  1998/01/20 13:16:29  michael
+  + Added flag for static/shared libs.
+
+  Revision 1.11  1998/01/17 01:57:32  michael
+  + Start of shared library support. First working version.
+
+  Revision 1.10  1998/01/16 12:52:09  michael
+  + Path treatment and file searching should now be more or less in their
+    definite form:
+    - Using now modified AddPathToList everywhere.
+    - File Searching mechanism is uniform for all files.
+    - Include path is working now !!
+    All fixes by Peter Vreman. Tested with remake3 target.
+
+  Revision 1.9  1998/01/16 00:00:54  michael
+  + Better and more modular searching and loading of units.
+    - searching in tmodule.search_unit.
+    - initial Loading in tmpodule.load_ppu.
+    - tmodule.init now calls search_unit.
+  * Case sensitivity problem of unix hopefully solved now forever.
+    (All from Peter Vreman, checked with remake3)
+
+  Revision 1.8  1998/01/15 13:07:46  michael
+  + added library treating stuff
+
+  Revision 1.7  1998/01/15 12:01:19  michael
+  * Linux prints now that actual name of the file being loaded.
+
+  Revision 1.6  1998/01/13 23:39:26  michael
+  * changed mechanism to look for unit file.
+  + added iblibraries constant to implement shared libraries.
+
+  Revision 1.5  1998/01/13 23:05:51  florian
+    + unit format 013 (change of options size, see symtable.pas log)
+
+  Revision 1.4  1998/01/13 17:13:06  michael
+  * File time handling and file searching is now done in an OS-independent way,
+    using the new file treating functions in globals.pas.
+
+  Revision 1.3  1998/01/07 00:16:49  michael
+  Restored released version (plus fixes) as current
+
+  Revision 1.2  1997/11/28 18:14:31  pierre
+   working version with several bug fixes
+
+  Revision 1.1.1.1  1997/11/27 08:32:56  michael
+  FPC Compiler CVS start
+
+
+  Pre-CVS log:
+
+  CEC  Carl-Eric Codere
+  FK   Florian Klaempfl
+  +    feature added
+  -    removed
+  *    bug fixed or changed
+
+  History (started with version 0.9.0):
+       2th december 1996:
+         + unit started  (FK)
+      22th december 1996:
+         + tinputfile added  (FK)
+      7th september 1997:
+         + moved main_module and current_module to const section
+           line ~319 and ~416: in_main initialized - added in_main
+           field to tmodule object  (CEC)
+
+}

compiler/gdb.pas

@@ -0,0 +1,268 @@
+{
+    $Id$
+    Copyright (c) 1996-98 by Florian Klaempfl
+
+    This units contains special support for the GDB
+
+    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 gdb;
+
+  interface
+
+    uses
+{$ifdef i386}
+       i386,
+{$endif i386}
+       strings,cobjects,globals,aasm;
+
+    {stab constants }
+Const
+    N_GSYM = $20;
+    N_STSYM = 38; {initialized const }
+    N_LCSYM = 40; {non initialized variable}
+    N_Function = $22; {function or const }
+    N_TextLine = $44;
+    N_DataLine = $46;
+    N_BssLine = $48;
+    N_RSYM = $40; { register variable }
+    N_LSYM = $80;
+    N_PSYM = 160;
+    N_SourceFile = $64;
+    N_IncludeFile = $84;
+    N_BINCL = $82;
+    N_EINCL = $A2;
+    N_EXCL  = $C2;
+
+    type
+       pai_stabs = ^tai_stabs;
+
+       tai_stabs = object(tai)
+          str : pchar;
+          constructor init(_str : pchar);
+          destructor done; virtual;
+       end;
+
+       pai_stabn = ^tai_stabn;
+
+       tai_stabn = object(tai)
+          str : pchar;
+          constructor init(_str : pchar);
+          destructor done; virtual;
+       end;
+
+       pai_stab_function_name = ^tai_stab_function_name;
+
+       tai_stab_function_name = object(tai)
+          str : pchar;
+          constructor init(_str : pchar);
+          destructor done; virtual;
+       end;
+
+const          DBX_counter : plongint = nil;
+               do_count_dbx : boolean = false;
+           { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi",
+            "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
+           { this is the register order for GDB }
+
+{$ifdef i386}
+       {tregister = (R_NO,R_EAX,R_ECX,R_EDX,R_EBX,R_ESP,R_EBP,R_ESI,R_EDI,
+                    R_AX,R_CX,R_DX,R_BX,R_SP,R_BP,R_SI,R_DI,
+                    R_AL,R_CL,R_DL,R_BL,R_AH,R_CH,R_BH,R_DH,
+                     for an easier assembler generation
+                    R_DEFAULT_SEG,R_CS,R_DS,R_ES,R_FS,R_GS,R_SS,
+                    R_ST,R_ST0,R_ST1,R_ST2,R_ST3,R_ST4,R_ST5,R_ST6,R_ST7); }
+           GDB_i386index : array[tregister] of shortint =
+           (-1,0,1,2,3,4,5,6,7,0,1,2,3,4,5,7,0,1,2,3,0,1,2,3,
+           -1,10,12,13,14,15,11,
+           -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
+           { I think, GDB doesn't know MMX (FK) }
+           -1,-1,-1,-1,-1,-1,-1,-1);
+{$endif i386}
+
+  implementation
+
+{$IfDef DBX}
+
+{ to use N_EXCL we have to count the character in the stabs for
+N_BINCL to N_EINCL
+  Code comes from stabs.c for ld
+      if (type == N_BINCL)
+    (
+      bfd_vma val;
+      int nest;
+      bfd_byte *incl_sym;
+      struct stab_link_includes_entry *incl_entry;
+      struct stab_link_includes_totals *t;
+      struct stab_excl_list *ne;
+
+      val = 0;
+      nest = 0;
+      for (incl_sym = sym + STABSIZE;
+           incl_sym < symend;
+           incl_sym += STABSIZE)
+        (
+          int incl_type;
+
+          incl_type = incl_sym[TYPEOFF];
+          if (incl_type == 0)
+        break;
+          else if (incl_type == N_EINCL)
+        (
+          if (nest == 0)
+            break;
+          --nest;
+        )
+          else if (incl_type == N_BINCL)
+        ++nest;
+          else if (nest == 0)
+        (
+          const char *str;
+
+          str = ((char *) stabstrbuf
+             + stroff
+             + bfd_get_32 (abfd, incl_sym + STRDXOFF));
+          for (; *str != '\0'; str++)
+            (
+              val += *str;
+              if (*str == '(')
+            (
+               Skip the file number.
+              ++str;
+              while (isdigit ((unsigned char) *str))
+                ++str;
+              --str;
+            )
+            )
+        )
+        ) }
+
+
+   procedure count_dbx(st : pchar);
+     var i : longint;
+         do_count : boolean;
+     begin
+     do_count := false;
+     if dbx_counter = nil then
+     else
+       begin
+{$IfDef ExtDebug }
+        Comment(V_Info,'Counting '+st);
+        Comment(V_Info,'count =  '+tostr(dbx_counter^));
+        Comment(V_Info,'addr = '+tostr(longint(dbx_counter)));
+{$EndIf ExtDebug }
+          for i:=0 to strlen(st) do
+            begin
+               if st[i] = '"' then
+                 if do_count then exit
+                 else do_count := true
+               else
+               if do_count then
+                 begin
+                   dbx_counter^ := dbx_counter^+byte(st[i]);
+                   if st[i] = '(' then
+                     begin
+                        inc(i);
+                        while st[i] in ['0'..'9'] do inc(i);
+                        dec(i);
+                     end;
+                 end;
+            end;
+       end;
+     end;
+
+{$EndIf DBX}
+
+    constructor tai_stabs.init(_str : pchar);
+
+      begin
+         inherited init;
+         typ:=ait_stabs;
+         str:=_str;
+{$IfDef DBX}
+         if do_count_dbx then
+           begin
+              count_dbx(str);
+              do_count_dbx := false;
+           end;
+{$EndIf DBX}
+      end;
+
+    destructor tai_stabs.done;
+
+      begin
+         strdispose(str);
+         inherited done;
+      end;
+
+    constructor tai_stabn.init(_str : pchar);
+
+      begin
+         inherited init;
+         typ:=ait_stabn;
+         str:=_str;
+      end;
+
+    destructor tai_stabn.done;
+
+      begin
+         strdispose(str);
+         inherited done;
+      end;
+
+    constructor tai_stab_function_name.init(_str : pchar);
+
+      begin
+         inherited init;
+         typ:=ait_stab_function_name;
+         str:=_str;
+      end;
+
+    destructor tai_stab_function_name.done;
+
+      begin
+         strdispose(str);
+         inherited done;
+      end;
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:13  root
+  Initial revision
+
+  Revision 1.5  1998/03/10 01:17:18  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.4  1998/03/02 01:48:33  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.3  1998/02/13 10:35:01  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.2  1997/11/28 18:14:32  pierre
+   working version with several bug fixes
+
+  Revision 1.1.1.1  1997/11/27 08:32:56  michael
+  FPC Compiler CVS start
+
+}

compiler/hcodegen.pas

@@ -0,0 +1,325 @@
+{
+    $Id$
+    Copyright (c) 1996-98 by Florian Klaempfl
+
+    This unit exports some help routines for the code generation
+
+    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 hcodegen;
+
+  interface
+
+     uses
+        cobjects,systems,globals,tree,symtable,types,strings,aasm
+{$ifdef i386}
+       ,i386
+{$endif}
+{$ifdef m68k}
+       ,m68k
+{$endif}
+       ;
+
+    const
+       { set, if the procedure uses asm }
+       pi_uses_asm = $1;
+       { set, if the procedure is exported by an unit }
+       pi_is_global = $2;
+       { set, if the procedure does a call }
+       { this is for the optimizer         }
+       pi_do_call = $4;
+       { if the procedure is an operator   }
+       pi_operator = $8;
+       { set, if the procedure is an external C function }
+       pi_C_import = $10;
+
+    type
+       pprocinfo = ^tprocinfo;
+
+       tprocinfo = record
+          { pointer to parent in nested procedures }
+          parent : pprocinfo;
+          { current class, if we are in a method }
+          _class : pobjectdef;
+          { return type }
+          retdef : pdef;
+          { frame pointer offset }
+          framepointer_offset : longint;
+          { self pointer offset }
+          ESI_offset : longint;
+          { result value offset }
+          retoffset : longint;
+
+          { firsttemp position }
+          firsttemp : longint;
+
+          funcret_is_valid : boolean;
+
+          { parameter offset }
+          call_offset : longint;
+
+          { some collected informations about the procedure }
+          { see pi_xxxx above                               }
+          flags : longint;
+
+          { register used as frame pointer }
+          framepointer : tregister;
+
+{$ifdef GDB}
+          { true, if the procedure is exported by an unit }
+          globalsymbol : boolean;
+{$endif * GDB *}
+
+          { true, if the procedure should be exported (only OS/2) }
+          exported : boolean;
+
+          { code for the current procedure }
+          aktproccode,aktentrycode,aktexitcode : paasmoutput;
+       end;
+
+    var
+       { info about the current sub routine }
+       procinfo : tprocinfo;
+
+       { Die Nummer der Label die bei BREAK bzw CONTINUE }
+       { angesprungen werden sollen }
+       aktbreaklabel,aktcontinuelabel : plabel;
+
+       { truelabel wird angesprungen, wenn ein Ausdruck true ist, falselabel }
+       { entsprechend                                                        }
+       truelabel,falselabel : plabel;
+
+       { Nr des Labels welches zum Verlassen eines Unterprogramm }
+       { angesprungen wird                                       }
+       aktexitlabel : plabel;
+
+       { also an exit label, only used we need to clear only the }
+       { stack                                                   }
+       aktexit2label : plabel;
+
+       { only used in constructor for fail or if getmem fails }
+       quickexitlabel : plabel;
+
+       { this asm list contains the debug info }
+       {debuginfos : paasmoutput;  debuglist is enough }
+
+       { Boolean, wenn eine loadn kein Assembler erzeugt hat }
+       simple_loadn : boolean;
+
+       { enth„lt die gesch„tzte Durchlaufanzahl*100 f�r den }
+       { momentan bearbeiteten Baum                         }
+       t_times : longint;
+
+       { true, if an error while code generation occurs }
+       codegenerror : boolean;
+
+    { some support routines for the case instruction }
+
+    { counts the labels }
+    function case_count_labels(root : pcaserecord) : longint;
+
+    { searches the highest label }
+    function case_get_max(root : pcaserecord) : longint;
+
+    { searches the lowest label }
+    function case_get_min(root : pcaserecord) : longint;
+
+    { concates the ASCII string to the const segment }
+    procedure generate_ascii(hs : string);
+
+    { inserts the ASCII string to the const segment }
+    procedure generate_ascii_insert(hs : string);
+
+    procedure generate_interrupt_stackframe_entry;
+    procedure generate_interrupt_stackframe_exit;
+
+  implementation
+
+{$ifdef i386}
+    procedure generate_interrupt_stackframe_entry;
+
+      begin
+         { save the registers of an interrupt procedure }
+         procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_EAX)));
+         procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_EBX)));
+         procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_ECX)));
+         procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_EDX)));
+         procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_ESI)));
+         procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_L,R_EDI)));
+
+         { .... also the segment registers }
+         procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_W,R_DS)));
+         procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_W,R_ES)));
+         procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_W,R_FS)));
+         procinfo.aktentrycode^.insert(new(pai386,op_reg(A_PUSH,S_W,R_GS)));
+      end;
+
+    procedure generate_interrupt_stackframe_exit;
+
+      begin
+         { restore the registers of an interrupt procedure }
+         { this was all with entrycode instead of exitcode !!}
+         procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_EAX)));
+         procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_EBX)));
+         procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_ECX)));
+         procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_EDX)));
+         procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_ESI)));
+         procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI)));
+
+         { .... also the segment registers }
+         procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_W,R_DS)));
+         procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_W,R_ES)));
+         procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_W,R_FS)));
+         procinfo.aktexitcode^.concat(new(pai386,op_reg(A_POP,S_W,R_GS)));
+
+        { this restores the flags }
+         procinfo.aktexitcode^.concat(new(pai386,op_none(A_IRET,S_NO)));
+      end;
+{$endif}
+{$ifdef m68k}
+    procedure generate_interrupt_stackframe_entry;
+      begin
+         { save the registers of an interrupt procedure }
+
+         { .... also the segment registers }
+      end;
+
+    procedure generate_interrupt_stackframe_exit;
+
+      begin
+         { restore the registers of an interrupt procedure }
+      end;
+{$endif}
+
+    procedure generate_ascii(hs : string);
+
+      begin
+         while length(hs)>32 do
+           begin
+              datasegment^.concat(new(pai_string,init(copy(hs,1,32))));
+              delete(hs,1,32);
+           end;
+         datasegment^.concat(new(pai_string,init(hs)))
+      end;
+
+    procedure generate_ascii_insert(hs : string);
+
+      begin
+         while length(hs)>32 do
+           begin
+              datasegment^.insert(new(pai_string,init(copy(hs,length(hs)-32+1,length(hs)))));
+              delete(hs,length(hs)-32+1,length(hs));
+           end;
+         datasegment^.insert(new(pai_string,init(hs)));
+      end;
+
+    function case_count_labels(root : pcaserecord) : longint;
+
+      var
+         _l : longint;
+
+      procedure count(p : pcaserecord);
+
+        begin
+           inc(_l);
+           if assigned(p^.less) then
+             count(p^.less);
+           if assigned(p^.greater) then
+             count(p^.greater);
+        end;
+
+      begin
+         _l:=0;
+         count(root);
+         case_count_labels:=_l;
+      end;
+
+    function case_get_max(root : pcaserecord) : longint;
+
+      var
+         hp : pcaserecord;
+
+      begin
+         hp:=root;
+         while assigned(hp^.greater) do
+           hp:=hp^.greater;
+         case_get_max:=hp^._high;
+      end;
+
+    function case_get_min(root : pcaserecord) : longint;
+
+      var
+         hp : pcaserecord;
+
+      begin
+         hp:=root;
+         while assigned(hp^.less) do
+           hp:=hp^.less;
+         case_get_min:=hp^._low;
+      end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:13  root
+  Initial revision
+
+  Revision 1.6  1998/03/10 16:27:38  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.5  1998/03/10 01:17:19  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.4  1998/03/02 01:48:37  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.3  1998/02/13 10:35:03  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.2  1998/01/16 18:03:15  florian
+    * small bug fixes, some stuff of delphi styled constructores added
+
+  Revision 1.1.1.1  1997/11/27 08:32:56  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
+
+  History:
+       5th september 1997:
+         + added support for MC68000 (CEC)
+      22th september 1997:
+         + added tprocinfo member parent (FK)
+}

compiler/i386.pas

@@ -0,0 +1,1834 @@
+{
+    $Id$
+    Copyright (c) 1995-98 by Florian Klaempfl
+
+    This unit implements an types and classes specific for the i386+
+
+    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 i386;
+
+  interface
+
+    uses
+       strings,systems,cobjects,globals,aasm,files,verbose;
+
+    const
+      extended_size = 10;
+
+    type
+       tasmop = (
+         A_MOV,A_MOVZX,A_MOVSX,A_LABEL,A_ADD,
+         A_CALL,A_IDIV,A_IMUL,A_JMP,A_LEA,A_MUL,A_NEG,A_NOT,
+         A_POP,A_POPAD,A_PUSH,A_PUSHAD,A_RET,A_SUB,A_XCHG,A_XOR,
+         A_FILD,A_CMP,A_JZ,A_INC,A_DEC,A_SETE,A_SETNE,A_SETL,
+         A_SETG,A_SETLE,A_SETGE,A_JE,A_JNE,A_JL,A_JG,A_JLE,A_JGE,
+         A_OR,A_FLD,A_FADD,A_FMUL,A_FSUB,A_FDIV,A_FCHS,A_FLD1,
+         A_FIDIV,A_CLTD,A_JNZ,A_FSTP,A_AND,A_JNO,A_NOTH,A_NONE,
+         A_ENTER,A_LEAVE,A_CLD,A_MOVS,A_REP,A_SHL,A_SHR,A_BOUND,
+         A_JNS,A_JS,A_JO,A_SAR,A_TEST,
+         A_FCOM,A_FCOMP,A_FCOMPP,A_FXCH,A_FADDP,A_FMULP,A_FSUBP,A_FDIVP,
+         A_FNSTS,A_SAHF,A_FDIVRP,A_FSUBRP,A_SETC,A_SETNC,A_JC,A_JNC,
+         A_JA,A_JAE,A_JB,A_JBE,A_SETA,A_SETAE,A_SETB,A_SETBE,
+         A_AAA,A_AAD,A_AAM,A_AAS,A_CBW,A_CDQ,A_CLC,A_CLI,
+         A_CLTS,A_CMC,A_CWD,A_CWDE,A_DAA,A_DAS,A_HLT,A_IRET,A_LAHF,
+         A_LODS,A_LOCK,A_NOP,A_PUSHA,A_PUSHF,A_PUSHFD,
+         A_STC,A_STD,A_STI,A_STOS,A_WAIT,A_XLAT,A_XLATB,A_MOVSB,
+         A_MOVSBL,A_MOVSBW,A_MOVSWL,A_MOVZB,A_MOVZWL,A_POPA,A_IN,
+         A_OUT,A_LDS,A_LCS,A_LES,A_LFS,A_LGS,A_LSS,A_POPF,A_SBB,A_ADC,
+         A_DIV,A_ROR,A_ROL,A_RCL,A_RCR,A_SAL,A_SHLD,A_SHRD,
+         A_LCALL,A_LJMP,A_LRET,A_JNAE,A_JNB,A_JNA,A_JNBE,A_JP,A_JNP,
+         A_JPE,A_JPO,A_JNGE,A_JNG,A_JNL,A_JNLE,A_JCXZ,A_JECXZ,
+         A_LOOP,A_CMPS,A_INS,A_OUTS,A_SCAS,A_BSF,A_BSR,A_BT,A_BTC,A_BTR,A_BTS,A_INT,
+         A_INT3,A_INTO,A_BOUNDL,A_BOUNDW,
+         A_LOOPZ,A_LOOPE,A_LOOPNZ,A_LOOPNE,A_SETO,A_SETNO,A_SETNAE,A_SETNB,
+         A_SETZ,A_SETNZ,A_SETNA,A_SETNBE,A_SETS,A_SETNS,A_SETP,A_SETPE,A_SETNP,
+         A_SETPO,A_SETNGE,A_SETNL,A_SETNG,A_SETNLE,A_ARPL,A_LAR,A_LGDT,A_LIDT,
+         A_LLDT,A_LMSW,A_LSL,A_LTR,A_SGDT,A_SIDT,A_SLDT,A_SMSW,A_STR,A_VERR,A_VERW,
+         A_FABS,A_FBLD,A_FBSTP,A_FCLEX,A_FNCLEX,
+         A_FCOS,A_FDECSTP,A_FDISI,A_FNDISI,
+         A_FDIVR,A_FENI,A_FNENI,A_FFREE,A_FIADD,A_FICOM,A_FICOMP,
+         A_FIDIVR,A_FIMUL,A_FINCSTP,A_FINIT,A_FNINIT,A_FIST,A_FISTP,A_FISUB,
+         A_FISUBR,A_FLDCW,A_FLDENV,A_FLDLG2,A_FLDLN2,A_FLDL2E,
+         A_FLDL2T,A_FLDPI,A_FLDS,A_FLDZ,A_FNOP,A_FPATAN,
+         A_FPREM,A_FPREM1,A_FPTAN,A_FRNDINT,A_FRSTOR,A_FSAVE,A_FNSAVE,
+         A_FSCALE,A_FSETPM,A_FSIN,A_FSINCOS,A_FSQRT,A_FST,A_FSTCW,A_FNSTCW,
+         A_FSTENV,A_FNSTENV,A_FSTSW,A_FNSTSW,A_FTST,A_FUCOM,A_FUCOMP,
+         A_FUCOMPP,A_FWAIT,A_FXAM,A_FXTRACT,A_FYL2X,A_FYL2XP1,A_F2XM1,
+         A_FILDQ,A_FILDS,A_FILDL,A_FLDL,A_FLDT,A_FISTQ,A_FISTS,A_FISTL,A_FSTL,A_FSTS,
+         A_FSTPS,A_FISTPL,A_FSTPL,A_FISTPS,A_FISTPQ,A_FSTPT,
+         A_FCOMPS,A_FICOMPL,A_FCOMPL,A_FICOMPS,
+         A_FCOMS,A_FICOML,A_FCOML,A_FICOMS,A_FIADDL,A_FADDL,A_FIADDS,
+         A_FISUBL,A_FSUBL,A_FISUBS,A_FSUBS,A_FSUBR,A_FSUBRS,A_FISUBRL,
+         A_FSUBRL,A_FISUBRS,A_FMULS,A_FIMULL,A_FMULL,A_FIMULS,A_FDIVS,A_FIDIVL,
+         A_FDIVL,A_FIDIVS,A_FDIVRS,A_FIDIVRL,A_FDIVRL,A_FIDIVRS,
+         A_REPE,A_REPNE,A_FADDS,A_POPFD,
+         { MMX instructions: }
+         A_EMMS,A_MOVD,A_MOVQ,A_PACKSSDW,A_PACKSSWB,A_PACKUSWB,
+         A_PADDB,A_PADDD,A_PADDSB,A_PADDSW,A_PADDUSB,A_PADDUSW,
+         A_PADDW,A_PAND,A_PANDN,A_PCMPEQB,A_PCMPEQD,A_PCMPEQW,
+         A_PCMPGTB,A_PCMPGTD,A_PCMPGTW,A_PMADDWD,A_PMULHW,
+         A_PMULLW,A_POR,A_PSLLD,A_PSLLQ,A_PSLLW,A_PSRAD,A_PSRAW,
+         A_PSRLD,A_PSRLQ,A_PSRLW,A_PSUBB,A_PSUBD,A_PSUBSB,A_PSUBSW,
+         A_PSUBUSB,A_PSUBUSW,A_PSUBW,A_PUNPCKHBW,A_PUNPCKHDQ,
+         A_PUNPCKHWD,A_PUNPCKLBW,A_PUNPCKLDQ,A_PUNPCKLWD,A_PXOR);
+    const
+      firstop = A_MOV;
+      lastop  = A_PXOR;
+
+    type
+       { enumeration for registers, don't change this }
+       { it's used by the register size converstaions }
+       tregister = (
+         R_NO,R_EAX,R_ECX,R_EDX,R_EBX,R_ESP,R_EBP,R_ESI,R_EDI,
+         R_AX,R_CX,R_DX,R_BX,R_SP,R_BP,R_SI,R_DI,
+         R_AL,R_CL,R_DL,R_BL,R_AH,R_CH,R_BH,R_DH,
+         { for an easier assembler generation }
+         R_DEFAULT_SEG,R_CS,R_DS,R_ES,R_FS,R_GS,R_SS,
+         R_ST,R_ST0,R_ST1,R_ST2,R_ST3,R_ST4,R_ST5,R_ST6,R_ST7,
+         R_MM0,R_MM1,R_MM2,R_MM3,R_MM4,R_MM5,R_MM6,R_MM7);
+
+       topsize = (S_NO,S_B,S_W,S_L,S_BW,S_BL,S_WL,S_Q,S_S,S_X,S_D);
+
+       plocation = ^tlocation;
+
+       { information about the location of an operand }
+       { LOC_FPUSTACK    FPU stack }
+       { LOC_REGISTER    in a processor register }
+       { LOC_MEM         in the memory }
+       { LOC_REFERENCE   like LOC_MEM, but lvalue }
+       { LOC_JUMP        nur bool'sche Resultate, Sprung zu false- oder }
+       {                 truelabel }
+       { LOC_FLAGS       nur bool'sche Rsultate, Flags sind gesetzt }
+       { LOC_CREGISTER   register which shouldn't be modified }
+       { LOC_INVALID     added for tracking problems}
+
+       tloc = (LOC_INVALID,LOC_FPU,LOC_REGISTER,LOC_MEM,LOC_REFERENCE,LOC_JUMP,
+               LOC_FLAGS,LOC_CREGISTER,LOC_MMXREGISTER,LOC_CMMXREGISTER);
+
+       tresflags = (F_E,F_NE,F_G,F_L,F_GE,F_LE,F_C,F_NC,
+                    F_A,F_AE,F_B,F_BE);
+
+       preference = ^treference;
+
+       treference = record
+          base,segment,index : tregister;
+          offset : longint;
+          symbol : pstring;
+          { a constant is also a treference, this makes the code generator }
+          { easier                                                         }
+          isintvalue : boolean;
+          scalefactor : byte;
+       end;
+
+       tlocation = record
+          case loc : tloc of
+             { segment in reference at the same place as in loc_register }
+             LOC_REGISTER,LOC_CREGISTER : (register,segment : tregister);
+             LOC_MEM,LOC_REFERENCE : (reference : treference);
+             LOC_FPU : ();
+             LOC_JUMP : ();
+             LOC_FLAGS : (resflags : tresflags);
+             LOC_INVALID : ();
+
+             { it's only for better handling }
+             LOC_MMXREGISTER : (mmxreg : tregister);
+       end;
+
+       pcsymbol = ^tcsymbol;
+
+       tcsymbol = record
+          symbol : pchar;
+          offset : longint;
+       end;
+
+    const
+       { arrays for boolean location conversions }
+       flag_2_jmp : array[F_E..F_BE] of tasmop =
+          (A_JE,A_JNE,A_JG,A_JL,A_JGE,A_JLE,A_JC,A_JNC,
+           A_JA,A_JAE,A_JB,A_JBE);
+
+       flag_2_set : array[F_E..F_BE] of tasmop =        { v-- the GAS didn't know setc }
+          (A_SETE,A_SETNE,A_SETG,A_SETL,A_SETGE,A_SETLE,A_SETB,A_SETAE,
+           A_SETA,A_SETAE,A_SETB,A_SETBE);
+
+       { operand types }
+       top_none = 0;
+       top_reg = 1;
+       top_ref = 2;
+
+       { a constant can be also written as treference }
+       top_const = 3;
+
+       { this is for calls }
+       top_symbol = 4;
+
+       stack_pointer = R_ESP;
+
+       frame_pointer = R_EBP;
+
+       {This constant is an alias for the accumulator, as it's name may
+        differ from processor to processor.}
+       accumulator = R_EAX;
+
+    type
+
+       pai_labeled = ^tai_labeled;
+
+       tai_labeled = object(tai)
+          _operator : tasmop;
+          lab : plabel;
+          constructor init(op : tasmop; l : plabel);
+          destructor done;virtual;
+       end;
+
+       pai386 = ^tai386;
+
+       tai386 = object(tai)
+          { this isn't a proper style, but not very memory expensive }
+          op1,op2: pointer;
+          _operator : tasmop;
+          opxt:word;
+          size:topsize;
+          constructor op_none(op : tasmop;_size : topsize);
+
+          constructor op_reg(op : tasmop;_size : topsize;_op1 : tregister);
+          constructor op_const(op : tasmop;_size : topsize;_op1 : longint);
+          constructor op_ref(op : tasmop;_size : topsize;_op1 : preference);
+          constructor op_loc(op : tasmop;_size : topsize;_op1 : tlocation);
+
+          constructor op_reg_reg(op : tasmop;_size : topsize;_op1,_op2 : tregister);
+          constructor op_reg_ref(op : tasmop;_size : topsize;_op1 : tregister;_op2 : preference);
+          constructor op_reg_loc(op : tasmop;_size : topsize;_op1 : tregister;_op2 : tlocation);
+          constructor op_loc_reg(op : tasmop;_size : topsize;_op1 : tlocation;_op2 : tregister);
+
+          constructor op_const_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister);
+          { this combination is needed by ENTER }
+          constructor op_const_const(op : tasmop;_size : topsize;_op1,_op2 : longint);
+          constructor op_const_ref(op : tasmop;_size : topsize;_op1 : longint;_op2 : preference);
+          constructor op_const_loc(op : tasmop;_size : topsize;_op1 : longint;_op2 : tlocation);
+
+          constructor op_ref_reg(op : tasmop;_size : topsize;_op1 : preference;_op2 : tregister);
+          { this is only allowed if _op1 is an int value (_op1^.isintvalue=true) }
+          constructor op_ref_ref(op : tasmop;_size : topsize;_op1,_op2 : preference);
+          {
+          constructor op_ref_loc(op : tasmop;_size : topsize;_op1 : preference;_op2 : tlcation);}
+
+          constructor op_const_reg_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister;_op3 : tregister);
+
+          { this is for CALL etc.                            }
+          { symbol is replaced by the address of symbol      }
+          { so op_csymbol(A_PUSH,S_L,strnew('P')); generates }
+          { an instruction which pushes the address of P     }
+          { to the stack                                     }
+          constructor op_csymbol(op : tasmop;_size : topsize;_op1 : pcsymbol);
+          constructor op_csymbol_reg(op : tasmop;_size : topsize;_op1 : pcsymbol;_op2 : tregister);
+          constructor op_csymbol_ref(op : tasmop;_size : topsize;_op1 : pcsymbol;_op2 : preference);
+          constructor op_csymbol_loc(op : tasmop;_size : topsize;_op1 : pcsymbol;_op2 : tlocation);
+          { OUT immediate8  }
+          constructor op_reg_const(op:tasmop; _size: topsize; _op1: tregister; _op2: longint);
+          function op1t:byte;
+          function op2t:byte;
+          function op3t:byte;
+          destructor done;virtual;
+       end;
+
+
+
+    const
+       maxvarregs = 4;
+
+       varregs : array[1..maxvarregs] of tregister =
+         (R_EBX,R_EDX,R_ECX,R_EAX);
+
+       nextlabelnr : longint = 1;
+
+    { the following functions allow to convert registers }
+    { for example reg8toreg32(R_AL) returns R_EAX        }
+    { for example reg16toreg32(R_AL) gives an undefined  }
+    { result                                             }
+    { these functions expects that the turn of           }
+    { tregister isn't changed                            }
+    function reg8toreg16(reg : tregister) : tregister;
+    function reg8toreg32(reg : tregister) : tregister;
+    function reg16toreg8(reg : tregister) : tregister;
+    function reg32toreg8(reg : tregister) : tregister;
+    function reg32toreg16(reg : tregister) : tregister;
+    function reg16toreg32(reg : tregister) : tregister;
+
+    { resets all values of ref to defaults }
+    procedure reset_reference(var ref : treference);
+
+    { same as reset_reference, but symbol is disposed }
+    { use this only for already used references       }
+    procedure clear_reference(var ref : treference);
+
+    { make l as a new label }
+    procedure getlabel(var l : plabel);
+    { frees the label if unused }
+    procedure freelabel(var l : plabel);
+    { make a new zero label }
+    procedure getzerolabel(var l : plabel);
+    { reset a label to a zero label }
+    procedure setzerolabel(var l : plabel);
+    {just get a label number }
+    procedure getlabelnr(var l : longint);
+
+    function newreference(const r : treference) : preference;
+
+    function reg2str(r : tregister) : string;
+
+    { generates an help record for constants }
+    function newcsymbol(const s : string;l : longint) : pcsymbol;
+
+    function lab2str(l : plabel) : string;
+
+    const
+       ao_unknown = $0;
+       { 8 bit reg }
+       ao_reg8 = $1;
+       { 16 bit reg }
+       ao_reg16 = $2;
+       { 32 bit reg }
+       ao_reg32 = $4;
+       ao_reg = (ao_reg8 or ao_reg16 or ao_reg32);
+
+       { for  push/pop operands }
+       ao_wordreg = (ao_reg16 or ao_reg32);
+       ao_imm8 = $8;        { 8 bit immediate }
+       ao_imm8S   = $10;        { 8 bit immediate sign extended }
+       ao_imm16   = $20;        { 16 bit immediate }
+       ao_imm32   = $40;        { 32 bit immediate }
+       ao_imm1    = $80;        { 1 bit immediate }
+
+       { for  unknown expressions }
+       ao_immunknown = ao_imm32;
+
+       { gen'l immediate }
+       ao_imm = (ao_imm8 or ao_imm8S or ao_imm16 or ao_imm32);
+       ao_disp8   = $200;       { 8 bit displacement (for  jumps) }
+       ao_disp16  = $400;       { 16 bit displacement }
+       ao_disp32  = $800;       { 32 bit displacement }
+
+       { general displacement }
+       ao_disp    = (ao_disp8 or ao_disp16 or ao_disp32);
+
+       { for  unknown size displacements }
+       ao_dispunknown = ao_disp32;
+       ao_mem8    = $1000;
+       ao_mem16   = $2000;
+       ao_mem32   = $4000;
+       ao_baseindex = $8000;
+
+       { general mem }
+       ao_mem     = (ao_disp or ao_mem8 or ao_mem16 or ao_mem32 or ao_baseindex);
+       ao_wordmem = (ao_mem16 or ao_mem32 or ao_disp or ao_baseindex);
+       ao_bytemem = (ao_mem8 or ao_disp or ao_baseindex);
+
+       { register to hold in/out port addr = dx }
+       ao_inoutportreg = $10000;
+       { register to hold shift cound = cl }
+       ao_shiftcount = $20000;
+       ao_control = $40000; { Control register }
+       ao_debug   = $80000; { Debug register }
+       ao_test    = $100000;    { Test register }
+
+       { suggestion from PM }
+       { st0 is also a float reg }
+
+       {ao_floatreg = $200000;  }{ Float register }
+       ao_otherfloatreg = $200000;  { Float register different from st0 }
+       ao_floatacc = $400000;   { Float stack top %st(0) }
+       ao_floatreg = ao_otherfloatreg or ao_floatacc; { all float regs }
+
+       { Florian correct this if it is wrong
+         but it seems necessary for ratti386 to accept the code
+         in i386/math.inc !! }
+
+       { 2 bit segment register }
+       ao_sreg2   = $800000;
+
+       { 3 bit segment register }
+       ao_sreg3   = $1000000;
+
+       { Accumulat or  %al  or  %ax  or  %eax }
+       ao_acc  = $2000000;
+       ao_implicitregister = (ao_inoutportreg or ao_shiftcount or ao_acc or ao_floatacc);
+       ao_jumpabsolute = $4000000;
+       ao_abs8 = $08000000;
+       ao_abs16 = $10000000;
+       ao_abs32 = $20000000;
+       ao_abs = (ao_abs8 or ao_abs16 or ao_abs32);
+
+       ao_none = $ff;
+
+
+       { this is for the code generator }
+       { set if operands are words or dwords }
+       af_w       = $1;
+       { D = 0 if Reg --> Regmem; D = 1 if Regmem --> Reg }
+       af_d        = $2;
+       { direction flag for floating insns:  MUST BE = $400 }
+       af_floatd = $400;
+       { shorthand }
+       af_dw = (af_d or af_w);
+       { register is in low 3 bits of opcode }
+       shortform = $10;
+       { shortform and w-bit is=$8 }
+       Shortformw = $20;
+       seg2shortform = $40; { encoding of load segment reg insns }
+       seg3shortform = $80; { fs/gs segment register insns. }
+       jump = $100;     { special case for jump insns. }
+       jumpintersegment = $200; { special case for intersegment leaps/calls }
+       dont_use = $400;
+       noModrm = $800;
+       modrm = $1000;
+       imulkludge = $2000;
+       Jumpbyte = $4000;
+       Jumpdword = $8000;
+       af_ReverseRegRegmem = $10000;
+
+    type
+       ttemplate = record
+          i : tasmop;
+          ops : byte;
+          oc : longint;
+          eb : byte;
+          m : longint;
+          o1,o2,o3 : longint;
+       end;
+
+       tins_cache = array[A_MOV..A_FADDS] of longint;
+
+    var
+       ins_cache : tins_cache;
+       exprasmlist : paasmoutput;
+
+    const
+       it : array[0..438] of ttemplate = (
+         (i : A_MOV;ops : 2;oc : $a0;eb : ao_none;m : af_dw or NoModrm;o1 : ao_disp32;o2 : ao_acc;o3 : 0 ),
+         (i : A_MOV;ops : 2;oc : $88;eb : ao_none;m : af_dw or Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0 ),
+         (i : A_MOV;ops : 2;oc : $b0;eb : ao_none;m : ShortFormW;o1 : ao_imm;o2 : ao_reg;o3 : 0 ),
+         (i : A_MOV;ops : 2;oc : $c6;eb : ao_none;m : af_w or Modrm;o1 : ao_imm;o2 : ao_reg or ao_mem;o3 : 0 ),
+         (i : A_MOV;ops : 2;oc : $8c;eb : ao_none;m : af_d or Modrm;o1 : ao_sreg3 or ao_sreg2;o2 : ao_reg16 or
+           ao_mem16;o3 : 0 ),
+         (i : A_MOV;ops : 2;oc : $0f20;eb : ao_none;m : af_d or Modrm;o1 : ao_control;o2 : ao_reg32;o3 : 0),
+         (i : A_MOV;ops : 2;oc : $0f21;eb : ao_none;m : af_d or Modrm;o1 : ao_debug;o2 : ao_reg32;o3 : 0),
+         (i : A_MOV;ops : 2;oc : $0f24;eb : ao_none;m : af_d or Modrm;o1 : ao_test;o2 : ao_reg32;o3 : 0),
+         (i : A_MOVSB;ops : 2;oc : $0fbe;eb : ao_none;m : af_reverseregregmem or Modrm;o1 : ao_reg8 or ao_mem;o2 : ao_reg16
+           or ao_reg32;o3 : 0),
+         (i : A_MOVSBL;ops : 2;oc : $0fbe;eb : ao_none;m : af_reverseregregmem or Modrm;o1 : ao_reg8 or ao_mem;
+           o2 : ao_reg32;o3 : 0),
+         (i : A_MOVSBW;ops : 2;oc : $660fbe;eb : ao_none;m : af_reverseregregmem or Modrm;o1 : ao_reg8 or ao_mem;
+           o2 : ao_reg16;o3 : 0),
+         (i : A_MOVSWL;ops : 2;oc : $0fbf;eb : ao_none;m : af_reverseregregmem or Modrm;o1 : ao_reg16 or ao_mem;
+           o2 : ao_reg32;o3 : 0),
+         (i : A_MOVZB;ops : 2;oc : $0fb6;eb : ao_none;m : af_reverseregregmem or Modrm;o1 : ao_reg8 or ao_mem;
+           o2 : ao_reg16 or ao_reg32;o3 : 0),
+         (i : A_MOVZWL;ops : 2;oc : $0fb7;eb : ao_none;m : af_reverseregregmem or Modrm;o1 : ao_reg16 or ao_mem;
+           o2 : ao_reg32;o3 : 0),
+         (i : A_PUSH;ops : 1;oc : $50;eb : ao_none;m : ShortForm;o1 : ao_wordreg;o2 : 0;o3 : 0 ),
+         (i : A_PUSH;ops : 1;oc : $ff;eb : $6;m : Modrm;o1 : ao_wordreg or ao_wordMem;o2 : 0;o3 : 0 ),
+         (i : A_PUSH;ops : 1;oc : $6a;eb : ao_none;m : NoModrm;o1 : ao_imm8S;o2 : 0;o3 : 0),
+         (i : A_PUSH;ops : 1;oc : $68;eb : ao_none;m : NoModrm;o1 : ao_imm32 or ao_imm16;o2 : 0;o3 : 0),
+         (i : A_PUSH;ops : 1;oc : $06;eb : ao_none;m : Seg2ShortForm;o1 : ao_sreg2;o2 : 0;o3 : 0 ),
+         (i : A_PUSH;ops : 1;oc : $0fa0;eb : ao_none;m : Seg3ShortForm;o1 : ao_sreg3;o2 : 0;o3 : 0 ),
+         (i : A_PUSHA;ops : 0;oc : $60;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0 ),
+         (i : A_PUSHAD; ops: 0; oc: $6660;eb: ao_none;m: NoModRm;o1:   0;o2:  0;o3:  0 ),
+         (i : A_POP;ops : 1;oc : $58;eb : ao_none;m : ShortForm;o1 : ao_wordreg;o2 : 0;o3 : 0 ),
+         (i : A_POP;ops : 1;oc : $8f;eb : $0;m : Modrm;o1 : ao_wordreg or ao_wordmem;o2 : 0;o3 : 0 ),
+         (i : A_POP;ops : 1;oc : $07;eb : ao_none;m : Seg2ShortForm;o1 : ao_sreg2;o2 : 0;o3 : 0 ),
+         (i : A_POP;ops : 1;oc : $0fa1;eb : ao_none;m : Seg3ShortForm;o1 : ao_sreg3;o2 : 0;o3 : 0 ),
+         (i : A_POPA;ops : 0;oc : $61;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0 ),
+         (i : A_POPAD; ops: 0; oc: $6661;eb: ao_none;m : NoModRm;o1 : 0;o2 : 0;o3: 0),
+         (i : A_XCHG;ops : 2;oc : $90;eb : ao_none;m : ShortForm;o1 : ao_wordreg;o2 : ao_acc;o3 : 0 ),
+         (i : A_XCHG;ops : 2;oc : $90;eb : ao_none;m : ShortForm;o1 : ao_acc;o2 : ao_wordreg;o3 : 0 ),
+         (i : A_XCHG;ops : 2;oc : $86;eb : ao_none;m : af_w or Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0 ),
+         (i : A_XCHG;ops : 2;oc : $86;eb : ao_none;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : ao_reg;o3 : 0 ),
+         (i : A_IN;ops : 2;oc : $e4;eb : ao_none;m : af_w or NoModrm;o1 : ao_imm8;o2 : ao_acc;o3 : 0 ),
+         (i : A_IN;ops : 2;oc : $ec;eb : ao_none;m : af_w or NoModrm;o1 : ao_inoutportreg;o2 : ao_acc;o3 : 0 ),
+         (i : A_OUT;ops : 2;oc : $e6;eb : ao_none;m : af_w or NoModrm;o1 : ao_acc;o2 : ao_imm8;o3 : 0 ),
+         (i : A_OUT;ops : 2;oc : $ee;eb : ao_none;m : af_w or NoModrm;o1 : ao_acc;o2 : ao_inoutportreg;o3 : 0 ),
+         (i : A_LEA;ops : 2;oc : $8d;eb : ao_none;m : Modrm;o1 : ao_wordmem;o2 : ao_wordreg;o3 : 0 ),
+         (i : A_LDS;ops : 2;oc : $c5;eb : ao_none;m : Modrm;o1 : ao_mem;o2 : ao_reg32;o3 : 0),
+         (i : A_LES;ops : 2;oc : $c4;eb : ao_none;m : Modrm;o1 : ao_mem;o2 : ao_reg32;o3 : 0),
+         (i : A_LFS;ops : 2;oc : $0fb4;eb : ao_none;m : Modrm;o1 : ao_mem;o2 : ao_reg32;o3 : 0),
+         (i : A_LGS;ops : 2;oc : $0fb5;eb : ao_none;m : Modrm;o1 : ao_mem;o2 : ao_reg32;o3 : 0),
+         (i : A_LSS;ops : 2;oc : $0fb2;eb : ao_none;m : Modrm;o1 : ao_mem;o2 : ao_reg32;o3 : 0),
+         (i : A_CLC;ops : 0;oc : $f8;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_CLD;ops : 0;oc : $fc;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_CLI;ops : 0;oc : $fa;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_CLTS;ops : 0;oc : $0f06;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_CMC;ops : 0;oc : $f5;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_LAHF;ops : 0;oc : $9f;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_SAHF;ops : 0;oc : $9e;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_PUSHF;ops : 0;oc : $9c;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_PUSHFD; ops: 0; oc: $669c; eb: ao_none; m: NoModRm; o1: 0;o2: 0;o3: 0),
+         (i : A_POPF;ops : 0;oc : $9d;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_POPFD;ops: 0;oc:  $669d;eb : ao_none;m : NoModRm;o1:  0;o2 : 0;o3 : 0),
+         (i : A_STC;ops : 0;oc : $f9;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_STD;ops : 0;oc : $fd;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_STI;ops : 0;oc : $fb;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_ADD;ops : 2;oc : $0;eb : ao_none;m : af_dw or Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_ADD;ops : 2;oc : $83;eb : 0;m : Modrm;o1 : ao_imm8s;o2 : ao_wordreg or ao_wordmem;o3 : 0),
+         (i : A_ADD;ops : 2;oc : $4;eb : ao_none;m : af_w or NoModrm;o1 : ao_imm;o2 : ao_acc;o3 : 0),
+         (i : A_ADD;ops : 2;oc : $80;eb : 0;m : af_w or Modrm;o1 : ao_imm;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_INC;ops : 1;oc : $40;eb : ao_none;m : ShortForm;o1 : ao_wordreg;o2 : 0;o3 : 0),
+         (i : A_INC;ops : 1;oc : $fe;eb : 0;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SUB;ops : 2;oc : $28;eb : ao_none;m : af_dw or Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SUB;ops : 2;oc : $83;eb : 5;m : Modrm;o1 : ao_imm8s;o2 : ao_wordreg or ao_wordmem;o3 : 0),
+         (i : A_SUB;ops : 2;oc : $2c;eb : ao_none;m : af_w or NoModrm;o1 : ao_imm;o2 : ao_acc;o3 : 0),
+         (i : A_SUB;ops : 2;oc : $80;eb : 5;m : af_w or Modrm;o1 : ao_imm;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_DEC;ops : 1;oc : $48;eb : ao_none;m : ShortForm;o1 : ao_wordreg;o2 : 0;o3 : 0),
+         (i : A_DEC;ops : 1;oc : $fe;eb : 1;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SBB;ops : 2;oc : $18;eb : ao_none;m : af_dw or Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SBB;ops : 2;oc : $83;eb : 3;m : Modrm;o1 : ao_imm8s;o2 : ao_wordreg or ao_wordmem;o3 : 0),
+         (i : A_SBB;ops : 2;oc : $1c;eb : ao_none;m : af_w or NoModrm;o1 : ao_imm;o2 : ao_acc;o3 : 0),
+         (i : A_SBB;ops : 2;oc : $80;eb : 3;m : af_w or Modrm;o1 : ao_imm;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_CMP;ops : 2;oc : $38;eb : ao_none;m : af_dw or Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_CMP;ops : 2;oc : $83;eb : 7;m : Modrm;o1 : ao_imm8s;o2 : ao_wordreg or ao_wordmem;o3 : 0),
+         (i : A_CMP;ops : 2;oc : $3c;eb : ao_none;m : af_w or NoModrm;o1 : ao_imm;o2 : ao_acc;o3 : 0),
+         (i : A_CMP;ops : 2;oc : $80;eb : 7;m : af_w or Modrm;o1 : ao_imm;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_TEST;ops : 2;oc : $84;eb : ao_none;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : ao_reg;o3 : 0),
+         (i : A_TEST;ops : 2;oc : $84;eb : ao_none;m : af_w or Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_TEST;ops : 2;oc : $a8;eb : ao_none;m : af_w or NoModrm;o1 : ao_imm;o2 : ao_acc;o3 : 0),
+         (i : A_TEST;ops : 2;oc : $f6;eb : 0;m : af_w or Modrm;o1 : ao_imm;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_AND;ops : 2;oc : $20;eb : ao_none;m : af_dw or Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_AND;ops : 2;oc : $83;eb : 4;m : Modrm;o1 : ao_imm8s;o2 : ao_wordreg or ao_wordmem;o3 : 0),
+         (i : A_AND;ops : 2;oc : $24;eb : ao_none;m : af_w or NoModrm;o1 : ao_imm;o2 : ao_acc;o3 : 0),
+         (i : A_AND;ops : 2;oc : $80;eb : 4;m : af_w or Modrm;o1 : ao_imm;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_OR;ops : 2;oc : $08;eb : ao_none;m : af_dw or Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_OR;ops : 2;oc : $83;eb : 1;m : Modrm;o1 : ao_imm8s;o2 : ao_wordreg or ao_wordmem;o3 : 0),
+         (i : A_OR;ops : 2;oc : $0c;eb : ao_none;m : af_w or NoModrm;o1 : ao_imm;o2 : ao_acc;o3 : 0),
+         (i : A_OR;ops : 2;oc : $80;eb : 1;m : af_w or Modrm;o1 : ao_imm;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_XOR;ops : 2;oc : $30;eb : ao_none;m : af_dw or Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_XOR;ops : 2;oc : $83;eb : 6;m : Modrm;o1 : ao_imm8s;o2 : ao_wordreg or ao_wordmem;o3 : 0),
+         (i : A_XOR;ops : 2;oc : $34;eb : ao_none;m : af_w or NoModrm;o1 : ao_imm;o2 : ao_acc;o3 : 0),
+         (i : A_XOR;ops : 2;oc : $80;eb : 6;m : af_w or Modrm;o1 : ao_imm;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_ADC;ops : 2;oc : $10;eb : ao_none;m : af_dw or Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_ADC;ops : 2;oc : $83;eb : 2;m : Modrm;o1 : ao_imm8s;o2 : ao_wordreg or ao_wordmem;o3 : 0),
+         (i : A_ADC;ops : 2;oc : $14;eb : ao_none;m : af_w or NoModrm;o1 : ao_imm;o2 : ao_acc;o3 : 0),
+         (i : A_ADC;ops : 2;oc : $80;eb : 2;m : af_w or Modrm;o1 : ao_imm;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_NEG;ops : 1;oc : $f6;eb : 3;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_NOT;ops : 1;oc : $f6;eb : 2;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_AAA;ops : 0;oc : $37;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_AAS;ops : 0;oc : $3f;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_DAA;ops : 0;oc : $27;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_DAS;ops : 0;oc : $2f;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_AAD;ops : 0;oc : $d50a;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_AAM;ops : 0;oc : $d40a;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_CBW;ops : 0;oc : $6698;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_CWD;ops : 0;oc : $6699;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_CWDE;ops : 0;oc : $98;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_CDQ;ops : 0;oc : $99;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_MUL;ops : 1;oc : $f6;eb : 4;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_IMUL;ops : 1;oc : $f6;eb : 5;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_IMUL;ops : 2;oc : $0faf;eb : ao_none;m : Modrm or af_reverseregregmem;o1 : ao_wordreg or ao_mem;
+           o2 : ao_wordreg;o3 : 0),
+         (i : A_IMUL;ops : 3;oc : $6b;eb : ao_none;m : Modrm or af_reverseregregmem;o1 : ao_imm8s;
+           o2 : ao_wordreg or ao_mem;o3 : ao_wordreg),
+         (i : A_IMUL;ops : 3;oc : $69;eb : ao_none;m : Modrm or af_reverseregregmem;o1 : ao_imm16 or ao_imm32;
+           o2 : ao_wordreg or ao_mem;o3 : ao_wordreg),
+         (i : A_IMUL;ops : 2;oc : $6b;eb : ao_none;m : Modrm or imulKludge;o1 : ao_imm8s;o2 : ao_wordreg;o3 : 0),
+         (i : A_IMUL;ops : 2;oc : $69;eb : ao_none;m : Modrm or imulKludge;o1 : ao_imm16 or ao_imm32;o2 : ao_wordreg;o3 : 0),
+         (i : A_DIV;ops : 1;oc : $f6;eb : 6;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_DIV;ops : 2;oc : $f6;eb : 6;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : ao_acc;o3 : 0),
+         (i : A_IDIV;ops : 1;oc : $f6;eb : 7;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_IDIV;ops : 2;oc : $f6;eb : 7;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : ao_acc;o3 : 0),
+         (i : A_ROL;ops : 2;oc : $d0;eb : 0;m : af_w or Modrm;o1 : ao_imm1;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_ROL;ops : 2;oc : $c0;eb : 0;m : af_w or Modrm;o1 : ao_imm8;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_ROL;ops : 2;oc : $d2;eb : 0;m : af_w or Modrm;o1 : ao_shiftcount;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_ROL;ops : 1;oc : $d0;eb : 0;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_ROR;ops : 2;oc : $d0;eb : 1;m : af_w or Modrm;o1 : ao_imm1;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_ROR;ops : 2;oc : $c0;eb : 1;m : af_w or Modrm;o1 : ao_imm8;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_ROR;ops : 2;oc : $d2;eb : 1;m : af_w or Modrm;o1 : ao_shiftcount;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_ROR;ops : 1;oc : $d0;eb : 1;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_RCL;ops : 2;oc : $d0;eb : 2;m : af_w or Modrm;o1 : ao_imm1;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_RCL;ops : 2;oc : $c0;eb : 2;m : af_w or Modrm;o1 : ao_imm8;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_RCL;ops : 2;oc : $d2;eb : 2;m : af_w or Modrm;o1 : ao_shiftcount;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_RCL;ops : 1;oc : $d0;eb : 2;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_RCR;ops : 2;oc : $d0;eb : 3;m : af_w or Modrm;o1 : ao_imm1;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_RCR;ops : 2;oc : $c0;eb : 3;m : af_w or Modrm;o1 : ao_imm8;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_RCR;ops : 2;oc : $d2;eb : 3;m : af_w or Modrm;o1 : ao_shiftcount;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_RCR;ops : 1;oc : $d0;eb : 3;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SAL;ops : 2;oc : $d0;eb : 4;m : af_w or Modrm;o1 : ao_imm1;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SAL;ops : 2;oc : $c0;eb : 4;m : af_w or Modrm;o1 : ao_imm8;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SAL;ops : 2;oc : $d2;eb : 4;m : af_w or Modrm;o1 : ao_shiftcount;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SAL;ops : 1;oc : $d0;eb : 4;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SHL;ops : 2;oc : $d0;eb : 4;m : af_w or Modrm;o1 : ao_imm1;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SHL;ops : 2;oc : $c0;eb : 4;m : af_w or Modrm;o1 : ao_imm8;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SHL;ops : 2;oc : $d2;eb : 4;m : af_w or Modrm;o1 : ao_shiftcount;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SHL;ops : 1;oc : $d0;eb : 4;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SHLD;ops : 3;oc : $0fa4;eb : ao_none;m : Modrm;o1 : ao_imm8;o2 : ao_wordreg;o3 : ao_wordreg or ao_mem),
+         (i : A_SHLD;ops : 3;oc : $0fa5;eb : ao_none;m : Modrm;o1 : ao_shiftcount;o2 : ao_wordreg;o3 : ao_wordreg or ao_mem),
+         (i : A_SHR;ops : 2;oc : $d0;eb : 5;m : af_w or Modrm;o1 : ao_imm1;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SHR;ops : 2;oc : $c0;eb : 5;m : af_w or Modrm;o1 : ao_imm8;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SHR;ops : 2;oc : $d2;eb : 5;m : af_w or Modrm;o1 : ao_shiftcount;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SHR;ops : 1;oc : $d0;eb : 5;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SHRD;ops : 3;oc : $0fac;eb : ao_none;m : Modrm;o1 : ao_imm8;o2 : ao_wordreg;o3 : ao_wordreg or ao_mem),
+         (i : A_SHRD;ops : 3;oc : $0fad;eb : ao_none;m : Modrm;o1 : ao_shiftcount;o2 : ao_wordreg;o3 : ao_wordreg or ao_mem),
+         (i : A_SAR;ops : 2;oc : $d0;eb : 7;m : af_w or Modrm;o1 : ao_imm1;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SAR;ops : 2;oc : $c0;eb : 7;m : af_w or Modrm;o1 : ao_imm8;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SAR;ops : 2;oc : $d2;eb : 7;m : af_w or Modrm;o1 : ao_shiftcount;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_SAR;ops : 1;oc : $d0;eb : 7;m : af_w or Modrm;o1 : ao_reg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_CALL;ops : 1;oc : $e8;eb : ao_none;m : jumpdword;o1 : ao_disp32;o2 : 0;o3 : 0),
+         (i : A_CALL;ops : 1;oc : $ff;eb : 2;m : Modrm;o1 : ao_reg or ao_mem or ao_jumpabsolute;o2 : 0;o3 : 0),
+         (i : A_LCALL;ops : 2;oc : $9a;eb : ao_none;m : JumpInterSegment;o1 : ao_imm16;o2 : ao_abs32;o3 : 0),
+         (i : A_LCALL;ops : 1;oc : $ff;eb : 3;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_JMP;ops : 1;oc : $eb;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JMP;ops : 1;oc : $ff;eb : 4;m : Modrm;o1 : ao_reg32 or ao_mem or ao_jumpabsolute;o2 : 0;o3 : 0),
+         (i : A_LJMP;ops : 2;oc : $ea;eb : ao_none;m : JumpInterSegment;o1 : ao_imm16;o2 : ao_imm32;o3 : 0),
+         (i : A_LJMP;ops : 1;oc : $ff;eb : 5;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_RET;ops : 0;oc : $c3;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_RET;ops : 1;oc : $c2;eb : ao_none;m : NoModrm;o1 : ao_imm16;o2 : 0;o3 : 0),
+         (i : A_LRET;ops : 0;oc : $cb;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_LRET;ops : 1;oc : $ca;eb : ao_none;m : NoModrm;o1 : ao_imm16;o2 : 0;o3 : 0),
+         (i : A_ENTER;ops : 2;oc : $c8;eb : ao_none;m : NoModrm;o1 : ao_imm16;o2 : ao_imm8;o3 : 0),
+         (i : A_LEAVE;ops : 0;oc : $c9;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_JO;ops : 1;oc : $70;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNO;ops : 1;oc : $71;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JB;ops : 1;oc : $72;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JC;ops : 1;oc : $72;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNAE;ops : 1;oc : $72;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNB;ops : 1;oc : $73;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNC;ops : 1;oc : $73;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JAE;ops : 1;oc : $73;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JE;ops : 1;oc : $74;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JZ;ops : 1;oc : $74;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNE;ops : 1;oc : $75;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNZ;ops : 1;oc : $75;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JBE;ops : 1;oc : $76;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNA;ops : 1;oc : $76;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNBE;ops : 1;oc : $77;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JA;ops : 1;oc : $77;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JS;ops : 1;oc : $78;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNS;ops : 1;oc : $79;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JP;ops : 1;oc : $7a;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JPE;ops : 1;oc : $7a;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNP;ops : 1;oc : $7b;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JPO;ops : 1;oc : $7b;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JL;ops : 1;oc : $7c;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNGE;ops : 1;oc : $7c;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNL;ops : 1;oc : $7d;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JGE;ops : 1;oc : $7d;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JLE;ops : 1;oc : $7e;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNG;ops : 1;oc : $7e;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JNLE;ops : 1;oc : $7f;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JG;ops : 1;oc : $7f;eb : ao_none;m : Jump;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JCXZ;ops : 1;oc : $67e3;eb : ao_none;m : JumpByte;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_JECXZ;ops : 1;oc : $e3;eb : ao_none;m : JumpByte;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_LOOP;ops : 1;oc : $e2;eb : ao_none;m : JumpByte;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_LOOPZ;ops : 1;oc : $e1;eb : ao_none;m : JumpByte;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_LOOPE;ops : 1;oc : $e1;eb : ao_none;m : JumpByte;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_LOOPNZ;ops : 1;oc : $e0;eb : ao_none;m : JumpByte;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_LOOPNE;ops : 1;oc : $e0;eb : ao_none;m : JumpByte;o1 : ao_disp;o2 : 0;o3 : 0),
+         (i : A_SETO;ops : 1;oc : $0f90;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNO;ops : 1;oc : $0f91;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETB;ops : 1;oc : $0f92;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNAE;ops : 1;oc : $0f92;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNB;ops : 1;oc : $0f93;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETAE;ops : 1;oc : $0f93;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETE;ops : 1;oc : $0f94;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETZ;ops : 1;oc : $0f94;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNE;ops : 1;oc : $0f95;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNZ;ops : 1;oc : $0f95;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETBE;ops : 1;oc : $0f96;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNA;ops : 1;oc : $0f96;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNBE;ops : 1;oc : $0f97;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETA;ops : 1;oc : $0f97;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETS;ops : 1;oc : $0f98;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNS;ops : 1;oc : $0f99;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETP;ops : 1;oc : $0f9a;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETPE;ops : 1;oc : $0f9a;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNP;ops : 1;oc : $0f9b;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETPO;ops : 1;oc : $0f9b;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETL;ops : 1;oc : $0f9c;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNGE;ops : 1;oc : $0f9c;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNL;ops : 1;oc : $0f9d;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETGE;ops : 1;oc : $0f9d;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETLE;ops : 1;oc : $0f9e;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNG;ops : 1;oc : $0f9e;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETNLE;ops : 1;oc : $0f9f;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SETG;ops : 1;oc : $0f9f;eb : 0;m : Modrm;o1 : ao_reg8 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_CMPS;ops : 0;oc : $a6;eb : ao_none;m : af_w or NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_INS;ops : 0;oc : $6c;eb : ao_none;m : af_w or NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_OUTS;ops : 0;oc : $6e;eb : ao_none;m : af_w or NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_LODS;ops : 0;oc : $ac;eb : ao_none;m : af_w or NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_MOVS;ops : 0;oc : $a4;eb : ao_none;m : af_w or NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_SCAS;ops : 0;oc : $ae;eb : ao_none;m : af_w or NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_STOS;ops : 0;oc : $aa;eb : ao_none;m : af_w or NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_XLAT;ops : 0;oc : $d7;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_BSF;ops : 2;oc : $0fbc;eb : ao_none;m : Modrm or af_reverseregregmem;o1 : ao_reg or ao_mem;o2 : ao_reg;o3 : 0),
+         (i : A_BSR;ops : 2;oc : $0fbd;eb : ao_none;m : Modrm or af_reverseregregmem;o1 : ao_reg or ao_mem;o2 : ao_reg;o3 : 0),
+         (i : A_BT;ops : 2;oc : $0fa3;eb : ao_none;m : Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_BT;ops : 2;oc : $0fba;eb : 4;m : Modrm;o1 : ao_imm8;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_BTC;ops : 2;oc : $0fbb;eb : ao_none;m : Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_BTC;ops : 2;oc : $0fba;eb : 7;m : Modrm;o1 : ao_imm8;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_BTR;ops : 2;oc : $0fb3;eb : ao_none;m : Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_BTR;ops : 2;oc : $0fba;eb : 6;m : Modrm;o1 : ao_imm8;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_BTS;ops : 2;oc : $0fab;eb : ao_none;m : Modrm;o1 : ao_reg;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_BTS;ops : 2;oc : $0fba;eb : 5;m : Modrm;o1 : ao_imm8;o2 : ao_reg or ao_mem;o3 : 0),
+         (i : A_INT;ops : 1;oc : $cd;eb : ao_none;m : NoModrm;o1 : ao_imm8;o2 : 0;o3 : 0),
+         (i : A_INT3;ops : 0;oc : $cc;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_INTO;ops : 0;oc : $ce;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_IRET;ops : 0;oc : $cf;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_BOUNDL;ops : 2;oc : $62;eb : ao_none;m : Modrm;o1 : ao_reg32;o2 : ao_mem;o3 : 0),
+         (i : A_BOUNDW;ops : 2;oc : $6662;eb : ao_none;m : Modrm;o1 : ao_reg16;o2 : ao_mem;o3 : 0),
+         (i : A_HLT;ops : 0;oc : $f4;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_wAIT;ops : 0;oc : $9b;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_NOP;ops : 0;oc : $90;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_ARPL;ops : 2;oc : $63;eb : ao_none;m : Modrm;o1 : ao_reg16;o2 : ao_reg16 or ao_mem;o3 : 0),
+         (i : A_LAR;ops : 2;oc : $0f02;eb : ao_none;m : Modrm or af_reverseregregmem;o1 : ao_wordreg or ao_mem;
+           o2 : ao_wordreg;o3 : 0),
+         (i : A_LGDT;ops : 1;oc : $0f01;eb : 2;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_LIDT;ops : 1;oc : $0f01;eb : 3;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_LLDT;ops : 1;oc : $0f00;eb : 2;m : Modrm;o1 : ao_wordreg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_LMSW;ops : 1;oc : $0f01;eb : 6;m : Modrm;o1 : ao_wordreg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_LSL;ops : 2;oc : $0f03;eb : ao_none;m : Modrm or af_reverseregregmem;o1 : ao_wordreg or ao_mem;
+           o2 : ao_wordreg;o3 : 0),
+         (i : A_LTR;ops : 1;oc : $0f00;eb : 3;m : Modrm;o1 : ao_wordreg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SGDT;ops : 1;oc : $0f01;eb : 0;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_SIDT;ops : 1;oc : $0f01;eb : 1;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_SLDT;ops : 1;oc : $0f00;eb : 0;m : Modrm;o1 : ao_wordreg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_SMSW;ops : 1;oc : $0f01;eb : 4;m : Modrm;o1 : ao_wordreg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_STR;ops : 1;oc : $0f00;eb : 1;m : Modrm;o1 : ao_reg16 or ao_mem;o2 : 0;o3 : 0),
+         (i : A_VERR;ops : 1;oc : $0f00;eb : 4;m : Modrm;o1 : ao_wordreg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_VERW;ops : 1;oc : $0f00;eb : 5;m : Modrm;o1 : ao_wordreg or ao_mem;o2 : 0;o3 : 0),
+         (i : A_FLD;ops : 1;oc : $d9c0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FLDS;ops : 1;oc : $d9;eb : 0;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FILDL;ops : 1;oc : $db;eb : 0;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FLDL;ops : 1;oc : $dd;eb : 0;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FLDL;ops : 1;oc : $d9c0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FILDS;ops : 1;oc : $df;eb : 0;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FILDQ;ops : 1;oc : $df;eb : 5;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FLDT;ops : 1;oc : $db;eb : 5;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FBLD;ops : 1;oc : $df;eb : 4;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FST;ops : 1;oc : $ddd0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FSTS;ops : 1;oc : $d9;eb : 2;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FISTL;ops : 1;oc : $db;eb : 2;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSTL;ops : 1;oc : $dd;eb : 2;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSTL;ops : 1;oc : $ddd0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FISTS;ops : 1;oc : $df;eb : 2;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSTP;ops : 1;oc : $ddd8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FSTPS;ops : 1;oc : $d9;eb : 3;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FISTPL;ops : 1;oc : $db;eb : 3;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSTPL;ops : 1;oc : $dd;eb : 3;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSTPL;ops : 1;oc : $ddd8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FISTPS;ops : 1;oc : $df;eb : 3;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FISTPQ;ops : 1;oc : $df;eb : 7;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSTPT;ops : 1;oc : $db;eb : 7;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FBSTP;ops : 1;oc : $df;eb : 6;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FXCH;ops : 1;oc : $d9c8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FCOM;ops : 1;oc : $d8d0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FCOMS;ops : 1;oc : $d8;eb : 2;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FICOML;ops : 1;oc : $da;eb : 2;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FCOML;ops : 1;oc : $dc;eb : 2;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FCOML;ops : 1;oc : $d8d0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FICOMS;ops : 1;oc : $de;eb : 2;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FCOMP;ops : 1;oc : $d8d8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FCOMPS;ops : 1;oc : $d8;eb : 3;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FICOMPL;ops : 1;oc : $da;eb : 3;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FCOMPL;ops : 1;oc : $dc;eb : 3;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FCOMPL;ops : 1;oc : $d8d8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FICOMPS;ops : 1;oc : $de;eb : 3;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FCOMPP;ops : 0;oc : $ded9;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FUCOM;ops : 1;oc : $dde0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FUCOMP;ops : 1;oc : $dde8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FUCOMPP;ops : 0;oc : $dae9;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FTST;ops : 0;oc : $d9e4;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FXAM;ops : 0;oc : $d9e5;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FLD1;ops : 0;oc : $d9e8;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FLDL2T;ops : 0;oc : $d9e9;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FLDL2E;ops : 0;oc : $d9ea;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FLDPI;ops : 0;oc : $d9eb;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FLDLG2;ops : 0;oc : $d9ec;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FLDLN2;ops : 0;oc : $d9ed;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FLDZ;ops : 0;oc : $d9ee;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FADD;ops : 1;oc : $d8c0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FADD;ops : 2;oc : $d8c0;eb : ao_none;m : ShortForm or af_floatd;o1 : ao_floatreg;o2 : ao_floatacc;o3 : 0),
+         (i : A_FADD;ops : 0;oc : $dcc1;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FADDP;ops : 1;oc : $dac0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FADDP;ops : 2;oc : $dac0;eb : ao_none;m : ShortForm or af_floatd;o1 : ao_floatreg;o2 : ao_floatacc;o3 : 0),
+         (i : A_FADDP;ops : 0;oc : $dec1;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FADDS;ops : 1;oc : $d8;eb : 0;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FIADDL;ops : 1;oc : $da;eb : 0;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FADDL;ops : 1;oc : $dc;eb : 0;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FIADDS;ops : 1;oc : $de;eb : 0;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSUB;ops : 1;oc : $d8e0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FSUB;ops : 2;oc : $d8e0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : ao_floatacc;o3 : 0),
+         (i : A_FSUB;ops : 2;oc : $dce8;eb : ao_none;m : ShortForm;o1 : ao_floatacc;o2 : ao_floatreg;o3 : 0),
+         (i : A_FSUB;ops : 0;oc : $dce1;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FSUBP;ops : 1;oc : $dae0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FSUBP;ops : 2;oc : $dae0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : ao_floatacc;o3 : 0),
+         (i : A_FSUBP;ops : 2;oc : $dee0;eb : ao_none;m : ShortForm;o1 : ao_floatacc;o2 : ao_floatreg;o3 : 0),
+         (i : A_FSUBP;ops : 0;oc : $dee1;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FSUBS;ops : 1;oc : $d8;eb : 4;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FISUBL;ops : 1;oc : $da;eb : 4;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSUBL;ops : 1;oc : $dc;eb : 4;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FISUBS;ops : 1;oc : $de;eb : 4;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSUBR;ops : 1;oc : $d8e8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FSUBR;ops : 2;oc : $d8e8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : ao_floatacc;o3 : 0),
+         (i : A_FSUBR;ops : 2;oc : $dce8;eb : ao_none;m : ShortForm;o1 : ao_floatacc;o2 : ao_floatreg;o3 : 0),
+         (i : A_FSUBR;ops : 0;oc : $dce9;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FSUBRP;ops : 1;oc : $dae8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FSUBRP;ops : 2;oc : $dae8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : ao_floatacc;o3 : 0),
+         (i : A_FSUBRP;ops : 2;oc : $dee8;eb : ao_none;m : ShortForm;o1 : ao_floatacc;o2 : ao_floatreg;o3 : 0),
+         (i : A_FSUBRP;ops : 0;oc : $dee9;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FSUBRS;ops : 1;oc : $d8;eb : 5;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FISUBRL;ops : 1;oc : $da;eb : 5;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSUBRL;ops : 1;oc : $dc;eb : 5;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FISUBRS;ops : 1;oc : $de;eb : 5;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FMUL;ops : 1;oc : $d8c8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FMUL;ops : 2;oc : $d8c8;eb : ao_none;m : ShortForm or af_floatd;o1 : ao_floatreg;o2 : ao_floatacc;o3 : 0),
+         (i : A_FMUL;ops : 0;oc : $dcc9;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FMULP;ops : 1;oc : $dac8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FMULP;ops : 2;oc : $dac8;eb : ao_none;m : ShortForm or af_floatd;o1 : ao_floatreg;o2 : ao_floatacc;o3 : 0),
+         (i : A_FMULP;ops : 0;oc : $dec9;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FMULS;ops : 1;oc : $d8;eb : 1;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FIMULL;ops : 1;oc : $da;eb : 1;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FMULL;ops : 1;oc : $dc;eb : 1;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FIMULS;ops : 1;oc : $de;eb : 1;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FDIV;ops : 1;oc : $d8f0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FDIV;ops : 2;oc : $d8f0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : ao_floatacc;o3 : 0),
+         (i : A_FDIV;ops : 2;oc : $dcf0;eb : ao_none;m : ShortForm;o1 : ao_floatacc;o2 : ao_floatreg;o3 : 0),
+         (i : A_FDIV;ops : 0;oc : $dcf1;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FDIVP;ops : 1;oc : $daf0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FDIVP;ops : 2;oc : $daf0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : ao_floatacc;o3 : 0),
+         (i : A_FDIVP;ops : 2;oc : $def0;eb : ao_none;m : ShortForm;o1 : ao_floatacc;o2 : ao_floatreg;o3 : 0),
+         (i : A_FDIVP;ops : 0;oc : $def1;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FDIVS;ops : 1;oc : $d8;eb : 6;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FIDIVL;ops : 1;oc : $da;eb : 6;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FDIVL;ops : 1;oc : $dc;eb : 6;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FIDIVS;ops : 1;oc : $de;eb : 6;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FDIVR;ops : 1;oc : $d8f8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FDIVR;ops : 2;oc : $d8f8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : ao_floatacc;o3 : 0),
+         (i : A_FDIVR;ops : 2;oc : $dcf8;eb : ao_none;m : ShortForm;o1 : ao_floatacc;o2 : ao_floatreg;o3 : 0),
+         (i : A_FDIVR;ops : 0;oc : $dcf9;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FDIVRP;ops : 1;oc : $daf8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FDIVRP;ops : 2;oc : $daf8;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : ao_floatacc;o3 : 0),
+         (i : A_FDIVRP;ops : 2;oc : $def8;eb : ao_none;m : ShortForm;o1 : ao_floatacc;o2 : ao_floatreg;o3 : 0),
+         (i : A_FDIVRP;ops : 0;oc : $def9;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FDIVRS;ops : 1;oc : $d8;eb : 7;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FIDIVRL;ops : 1;oc : $da;eb : 7;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FDIVRL;ops : 1;oc : $dc;eb : 7;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FIDIVRS;ops : 1;oc : $de;eb : 7;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_F2XM1;ops : 0;oc : $d9f0;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FYL2X;ops : 0;oc : $d9f1;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FPTAN;ops : 0;oc : $d9f2;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FPATAN;ops : 0;oc : $d9f3;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FXTRACT;ops : 0;oc : $d9f4;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FPREM1;ops : 0;oc : $d9f5;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FDECSTP;ops : 0;oc : $d9f6;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FINCSTP;ops : 0;oc : $d9f7;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FPREM;ops : 0;oc : $d9f8;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FYL2XP1;ops : 0;oc : $d9f9;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FSQRT;ops : 0;oc : $d9fa;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FSINCOS;ops : 0;oc : $d9fb;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FRNDINT;ops : 0;oc : $d9fc;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FSCALE;ops : 0;oc : $d9fd;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FSIN;ops : 0;oc : $d9fe;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FCOS;ops : 0;oc : $d9ff;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FCHS;ops : 0;oc : $d9e0;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FABS;ops : 0;oc : $d9e1;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FNINIT;ops : 0;oc : $dbe3;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FINIT;ops : 0;oc : $dbe3;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FLDCW;ops : 1;oc : $d9;eb : 5;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FNSTCW;ops : 1;oc : $d9;eb : 7;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSTCW;ops : 1;oc : $d9;eb : 7;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FNSTSW;ops : 1;oc : $dfe0;eb : ao_none;m : NoModrm;o1 : ao_acc;o2 : 0;o3 : 0),
+         (i : A_FNSTSW;ops : 1;oc : $dd;eb : 7;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FNSTSW;ops : 0;oc : $dfe0;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FSTSW;ops : 1;oc : $dfe0;eb : ao_none;m : NoModrm;o1 : ao_acc;o2 : 0;o3 : 0),
+         (i : A_FSTSW;ops : 1;oc : $dd;eb : 7;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSTSW;ops : 0;oc : $dfe0;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FNCLEX;ops : 0;oc : $dbe2;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FCLEX;ops : 0;oc : $dbe2;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FNSTENV;ops : 1;oc : $d9;eb : 6;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSTENV;ops : 1;oc : $d9;eb : 6;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FLDENV;ops : 1;oc : $d9;eb : 4;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FNSAVE;ops : 1;oc : $dd;eb : 6;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FSAVE;ops : 1;oc : $dd;eb : 6;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FRSTOR;ops : 1;oc : $dd;eb : 4;m : Modrm;o1 : ao_mem;o2 : 0;o3 : 0),
+         (i : A_FFREE;ops : 1;oc : $ddc0;eb : ao_none;m : ShortForm;o1 : ao_floatreg;o2 : 0;o3 : 0),
+         (i : A_FNOP;ops : 0;oc : $d9d0;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FWAIT;ops : 0;oc : $9b;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+{         (i : A_ADDRaf_wORD;ops : 0;oc : $67;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0), }
+{         (i : A_WORD;ops : 0;oc : $66;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0), }
+         (i : A_LOCK;ops : 0;oc : $f0;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+{         (i : A_CS;ops : 0;oc : $2e;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_DS;ops : 0;oc : $3e;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_ES;ops : 0;oc : $26;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_FS;ops : 0;oc : $64;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_GS;ops : 0;oc : $65;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_SS;ops : 0;oc : $36;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0), }
+         (i : A_REP;ops : 0;oc : $f3;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_REPE;ops : 0;oc : $f3;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_REPNE;ops : 0;oc : $f2;eb : ao_none;m : NoModrm;o1 : 0;o2 : 0;o3 : 0),
+         (i : A_NONE));
+
+{****************************************************************************
+                            Assembler Mnemoics
+****************************************************************************}
+
+     att_op2str : array[firstop..lastop] of string[7] =
+       ('mov','movz','movs','','add',
+        'call','idiv','imul','jmp','lea','mul','neg','not',
+        'pop','popal','push','pushal','ret','sub','xchg','xor',
+        'fild','cmp','jz','inc','dec','sete','setne','setl',
+        'setg','setle','setge','je','jne','jl','jg','jle','jge',
+        'or','fld','fadd','fmul','fsub','fdiv','fchs','fld1',
+        'fidiv','cltd','jnz','fstp','and','jno','','',
+        'enter','leave','cld','movs','rep','shl','shr','bound',
+        'jns','js','jo','sar','test',
+        'fcom','fcomp','fcompp','fxch','faddp','fmulp','fsubp','fdivp',
+        'fnsts','sahf','fdivrp','fsubrp','setc','setnc','jc','jnc',
+        'ja','jae','jb','jbe','seta','setae','setb','setbe',
+        'aaa','aad','aam','aas','cbw','cdq','clc','cli',
+        'clts','cmc','cwd','cwde','daa','das','hlt','iret','lahf',
+        'lods','lock','nop','pusha','pushf','pushfd',
+        'stc','std','sti','stos','wait','xlat','xlatb','movsb',
+        'movsbl','movsbw','movswl','movsb','movzwl','popa','in',
+        'out','lds','lcs','les','lfs','lgs','lss','popf','sbb','adc',
+        'div','ror','rol','rcl','rcr','sal','shld','shrd',
+        'lcall','ljmp','lret','jnae','jnb','jna','jnbe','jb','jnp',
+        'jpe','jpo','jnge','jng','jnl','jnle','jcxz','jecxz',
+        'loop','cmps','ins','outs','scas','bsf','bsr','bt','btc',
+        'btr','bts','int','int3','into','boundl','boundw',
+        'loopz','loope','loopnz','loopne','seto','setno','setnae',
+        'setnb','setz','setnz','setna','setnbe','sets','setns','setp',
+        'setpe','setnp','setpo','setnge','setnl','setng','setnle',
+        'arpl','lar','lgdt','lidt','lldt','lmsw','lsl','ltr','sgdt',
+        'sidt','sldt','smsw','str','verr','verw','fabs','fbld','fbstp',
+        'fclex','fnclex','fcos','fdecstp','fdisi','fndisi','fdivr',
+        'feni','fneni','ffree','fiadd','ficom','ficomp','fidivr',
+        'fimul','fincstp','finit','fninit','fist','fistp','fisub',
+        'fisubr','fldcw','fldenv','fldlg2','fldln2','fldl2e','fldl2t',
+        'fldpi','flds','fldz','fnop','fpatan','fprem','fprem1','fptan',
+        'frndint','frstor','fsave','fnsave','fscale','fsetpm','fsin',
+        'fsincos','fsqrt','fst','fstcw','fnstcw','fstenv','fnstenv',
+        'fstsw','fnstsw','ftst','fucom','fucomp','fucompp','fwait',
+        'fxam','fxtract','fyl2x','fyl2xp1','f2xm1','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',
+        { mmx instructions supported by GNU AS v281 }
+        'emms','movd','movq','packssdw','packsswb','packuswb',
+        'paddb','paddd','paddsb','paddsw','paddusb','paddusw',
+        'paddw','pand','pandn','pcmpeqb','pcmpeqd','pcmpeqw',
+        'pcmpgtb','pcmpgtd','pcmpgtw','pmaddwd','pmulhw',
+        'pmullw','por','pslld','psllq','psllw','psrad','psraw',
+        'psrld','psrlq','psrlw','psubb','psubd','psubsb','psubsw',
+        'psubusb','psubusw','psubw','punpckhbw','punpckhdq',
+        'punpckhwd','punpcklbw','punpckldq','punpcklwd','pxor');
+
+     att_opsize2str : array[topsize] of string[2] =
+       ('','b','w','l','bw','bl','wl','q','s','t','d');
+
+     att_reg2str : array[tregister] of string[6] =
+       ('','%eax','%ecx','%edx','%ebx','%esp','%ebp','%esi','%edi',
+        '%ax','%cx','%dx','%bx','%sp','%bp','%si','%di',
+        '%al','%cl','%dl','%bl','%ah','%ch','%bh','%dh',
+        '','%cs','%ds','%es','%fs','%gs','%ss',
+        '%st','%st(0)','%st(1)','%st(2)','%st(3)','%st(4)',
+        '%st(5)','%st(6)','%st(7)',
+        '%mm0','%mm1','%mm2','%mm3',
+        '%mm4','%mm5','%mm6','%mm7');
+
+      int_op2str : array[firstop..lastop] of string[9] =
+       ('mov','movzx','movsx','','add',
+        'call','idiv','imul','jmp','lea','mul','neg','not',
+        'pop','popad','push','pushad','ret','sub','xchg','xor',
+        'fild','cmp','jz','inc','dec','sete','setne','setl',
+        'setg','setle','setge','je','jne','jl','jg','jle','jge',
+        'or','fld','fadd','fmul','fsub','fdiv','fchs','fld1',
+        'fidiv','cdq','jnz','fstp','and','jno','','',
+        'enter','leave','cld','movs','rep','shl','shr','bound',
+        'jns','js','jo','sar','test',
+        'fcom','fcomp','fcompp','fxch','faddp','fmulp','fsubrp','fdivp',
+        'fnsts','sahf','fdivp','fsubp','setc','setnc','jc','jnc',
+        'ja','jae','jb','jbe','seta','setae','setb','setbe',
+        'aaa','aad','aam','aas','cbw','cdq','clc','cli',
+        'clts','cmc','cwd','cwde','daa','das','hlt','iret','lahf',
+        'lods','lock','nop','pusha','pushf','pushfd',
+        'stc','std','sti','stos','wait','xlat','xlatb','movsx',
+        'movsx','movsx','movsx','movsx','movzx','popa','in',
+        'out','lds','lcs','les','lfs','lgs','lss','popf','sbb','adc',
+        'div','ror','rol','rcl','rcr','sal','shld','shrd',
+        'call','jmp','ret','jnae','jnb','jna','jnbe','jb','jnp',
+        'jpe','jpo','jnge','jng','jnl','jnle','jcxz','jecxz',
+        'loop','cmps','ins','outs','scas','bsf','bsr','bt','btc',
+        'btr','bts','int','int3','into','bound','bound',
+        'loopz','loope','loopnz','loopne','seto','setno','setnae',
+        'setnb','setz','setnz','setna','setnbe','sets','setns','setp',
+        'setpe','setnp','setpo','setnge','setnl','setng','setnle',
+        'arpl','lar','lgdt','lidt','lldt','lmsw','lsl','ltr','sgdt',
+        'sidt','sldt','smsw','str','verr','verw','fabs','fbld','fbstp',
+        'fclex','fnclex','fcos','fdecstp','fdisi','fndisi','fdivr',
+        'feni','fneni','ffree','fiadd','ficom','ficomp','fidivr',
+        'fimul','fincstp','finit','fninit','fist','fistp','fisub',
+        'fisubr','fldcw','fldenv','fldlg2','fldln2','fldl2e','fldl2t',
+        'fldpi','flds','fldz','fnop','fpatan','fprem','fprem1','fptan',
+        'frndint','frstor','fsave','fnsave','fscale','fsetpm','fsin',
+        'fsincos','fsqrt','fst','fstcw','fnstcw','fstenv','fnstenv',
+        'fstsw','fnstsw','ftst','fucom','fucomp','fucompp','fwait',
+        'fxam','fxtract','fyl2x','fyl2xp1','f2xm1','fildq','filds',
+        'fildl','fldl','fldt','fistq','fists','fistl','fstl','fsts',
+        'fstps','fistpl','fstpl','fistps','fistpq','fstpt','fcomps',
+        'ficompl','fcompl','ficomps','fcoms','ficoml','fcoml','ficoms',
+        'fiadd','fadd','fiadd','fisub','fsub','fisub','fsub',
+        'fsubr','fsubr','fisubr','fsubr','fisubr','fmul','fimul',
+        'fmul','fimul','fdiv','fidiv','fdiv','fidiv','fdivr',
+        'fidivr','fdivr','fidivr','repe','repne','fadd','popfd',
+        { mmx instructions }
+        'emms','movd','movq','packssdw','packsswb','packuswb',
+        'paddb','paddd','paddsb','paddsw','paddusb','paddusw',
+        'paddw','pand','pandn','pcmpeqb','pcmpeqd','pcmpeqw',
+        'pcmpgtb','pcmpgtd','pcmpgtw','pmaddwd','pmulhw',
+        'pmullw','por','pslld','psllq','psllw','psrad','psraw',
+        'psrld','psrlq','psrlw','psubb','psubd','psubsb','psubsw',
+        'psubusb','psubusw','psubw','punpckhbw','punpckhdq',
+        'punpckhwd','punpcklbw','punpckldq','punpcklwd','pxor');
+
+     int_reg2str : array[tregister] of string[5] =
+       ('','eax','ecx','edx','ebx','esp','ebp','esi','edi',
+        'ax','cx','dx','bx','sp','bp','si','di',
+        'al','cl','dl','bl','ah','ch','bh','dh',
+        '','cs','ds','es','fs','gs','ss',
+        'st','st(0)','st(1)','st(2)','st(3)','st(4)','st(5)','st(6)','st(7)',
+        'mm0','mm1','mm2','mm3','mm4','mm5','mm6','mm7');
+
+     int_nasmreg2str : array[tregister] of string[5] =
+       ('','eax','ecx','edx','ebx','esp','ebp','esi','edi',
+        'ax','cx','dx','bx','sp','bp','si','di',
+        'al','cl','dl','bl','ah','ch','bh','dh',
+        '','cs','ds','es','fs','gs','ss',
+        'st0','st0','st1','st2','st3','st4','st5','st6','st7',
+        'mm0','mm1','mm2','mm3','mm4','mm5','mm6','mm7');
+
+
+  implementation
+
+    function reg2str(r : tregister) : string;
+
+      const
+         a : array[R_NO..R_BL] of string[3] =
+          ('','EAX','ECX','EDX','EBX','ESP','EBP','ESI','EDI',
+           'AX','CX','DX','BX','SP','BP','SI','DI',
+           'AL','CL','DL','BL');
+
+      begin
+         reg2str:=a[r];
+      end;
+
+    function newreference(const r : treference) : preference;
+
+      var
+         p : preference;
+
+      begin
+         new(p);
+         p^:=r;
+         if assigned(r.symbol) then
+           p^.symbol:=stringdup(r.symbol^);
+         newreference:=p;
+      end;
+
+    function lab2str(l : plabel) : string;
+
+      begin
+         if (l=nil) or (l^.nb=0) then
+{$ifdef EXTDEBUG}
+           lab2str:='ILLEGAL'
+         else
+         begin
+           if not(current_module^.output_format in [of_obj,of_nasm]) then
+              lab2str:=target_info.labelprefix+tostr(l^.nb)
+           else
+              lab2str:='?L'+tostr(l^.nb);
+         end;
+{$else EXTDEBUG}
+           internalerror(2000);
+           if not(current_module^.output_format in [of_obj,of_nasm]) then
+              lab2str:=target_info.labelprefix+tostr(l^.nb)
+           else
+              lab2str:='?L'+tostr(l^.nb);
+{$endif EXTDEBUG}
+         { was missed: }
+         inc(l^.refcount);
+         l^.is_used:=true;
+      end;
+
+    function reg8toreg16(reg : tregister) : tregister;
+
+      begin
+         reg8toreg16:=reg32toreg16(reg8toreg32(reg));
+      end;
+
+    function reg16toreg8(reg : tregister) : tregister;
+
+      begin
+         reg16toreg8:=reg32toreg8(reg16toreg32(reg));
+      end;
+
+    function reg16toreg32(reg : tregister) : tregister;
+
+      begin
+         reg16toreg32:=tregister(byte(reg)-byte(R_EDI));
+      end;
+
+    function reg32toreg16(reg : tregister) : tregister;
+
+      begin
+         reg32toreg16:=tregister(byte(reg)+byte(R_EDI));
+      end;
+
+    function reg32toreg8(reg : tregister) : tregister;
+
+      begin
+         reg32toreg8:=tregister(byte(reg)+byte(R_DI));
+      end;
+
+    function reg8toreg32(reg : tregister) : tregister;
+
+      begin
+         reg8toreg32:=tregister(byte(reg)-byte(R_DI));
+      end;
+
+    procedure reset_reference(var ref : treference);
+
+      begin
+{$ifdef ver0_6}
+         ref.index:=R_NO;
+         ref.base:=R_NO;
+         ref.segment:=R_DEFAULT_SEG;
+         ref.offset:=0;
+         ref.scalefactor:=1;
+         ref.isintvalue:=false;
+         ref.symbol:=nil;
+{$else}
+         with ref do
+           begin
+              index:=R_NO;
+              base:=R_NO;
+              segment:=R_DEFAULT_SEG;
+              offset:=0;
+              scalefactor:=1;
+              isintvalue:=false;
+              symbol:=nil;
+           end;
+{$endif}
+      end;
+
+    procedure clear_reference(var ref : treference);
+
+      begin
+         stringdispose(ref.symbol);
+         reset_reference(ref);
+      end;
+
+    procedure getlabel(var l : plabel);
+
+      begin
+         new(l);
+         l^.nb:=nextlabelnr;
+         l^.is_used:=false;
+         l^.is_set:=false;
+         l^.refcount:=0;
+         inc(nextlabelnr);
+      end;
+
+    procedure freelabel(var l : plabel);
+
+      begin
+         if (l<>nil) and (not l^.is_set) and (not l^.is_used) then
+           dispose(l);
+         l:=nil;
+      end;
+
+    procedure setzerolabel(var l : plabel);
+
+      begin
+         l^.nb:=0;
+         l^.is_used:=false;
+         l^.is_set:=false;
+         l^.refcount:=0;
+      end;
+
+    procedure getzerolabel(var l : plabel);
+
+      begin
+         new(l);
+         l^.nb:=0;
+         l^.is_used:=false;
+         l^.is_set:=false;
+         l^.refcount:=0;
+      end;
+
+    procedure getlabelnr(var l : longint);
+
+      begin
+         l:=nextlabelnr;
+         inc(nextlabelnr);
+      end;
+
+    function newcsymbol(const s : string;l : longint) : pcsymbol;
+
+      var
+         p : pcsymbol;
+
+      begin
+         new(p);
+         p^.symbol:=strpnew(s);
+         p^.offset:=l;
+         newcsymbol:=p;
+      end;
+
+    procedure disposecsymbol(p : pcsymbol);
+
+      begin
+      strdispose(p^.symbol);
+      dispose(p);
+      end;
+
+{****************************************************************************
+                             TAI386
+ ****************************************************************************}
+
+    constructor tai386.op_none(op : tasmop;_size : topsize);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=0;
+         size:=_size;
+
+         { the following isn't required ! }
+         op1:=nil;
+         op2:=nil;
+      end;
+
+    constructor tai386.op_reg(op : tasmop;_size : topsize;_op1 : tregister);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=Top_reg;
+         size:=_size;
+         op1:=pointer(_op1);
+
+         op2:=nil;
+      end;
+
+    constructor tai386.op_const(op : tasmop;_size : topsize;_op1 : longint);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=Top_const;
+         size:=_size;
+         op1:=pointer(_op1);
+
+         op2:=nil;
+      end;
+
+    constructor tai386.op_ref(op : tasmop;_size : topsize;_op1 : preference);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         size:=_size;
+         if _op1^.isintvalue then
+           begin
+              opxt:=top_const;
+              op1:=pointer(_op1^.offset);
+           end
+         else
+           begin
+              opxt:=top_ref;
+              op1:=pointer(_op1);
+           end;
+
+         op2:=nil;
+      end;
+
+    constructor tai386.op_loc(op : tasmop;_size : topsize;_op1 : tlocation);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         size:=_size;
+         if (_op1.loc=loc_register) or (_op1.loc=loc_cregister)  then
+           begin
+             opxt:=top_reg;
+             op1:=pointer(_op1.register);
+           end
+         else
+         if _op1.reference.isintvalue then
+           begin
+              opxt:=top_const;
+              op1:=pointer(_op1.reference.offset);
+           end
+         else
+           begin
+              opxt:=top_ref;
+              op1:=pointer(newreference(_op1.reference));
+           end;
+
+         op2:=nil;
+      end;
+
+    constructor tai386.op_reg_reg(op : tasmop;_size : topsize;_op1,_op2 : tregister);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=Top_reg shl 4+Top_reg;
+         size:=_size;
+         op1:=pointer(_op1);
+         op2:=pointer(_op2);
+
+      end;
+
+    constructor tai386.op_reg_ref(op : tasmop;_size : topsize;_op1 : tregister;_op2 : preference);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=top_reg;
+         size:=_size;
+         op1:=pointer(_op1);
+
+         if _op2^.isintvalue then
+           begin
+              opxt:=opxt+top_const shl 4;
+              op2:=pointer(_op2^.offset);
+           end
+         else
+           begin
+              opxt:=opxt+top_ref shl 4;
+              op2:=pointer(_op2);
+           end;
+
+      end;
+
+    constructor tai386.op_reg_loc(op : tasmop;_size : topsize;_op1 : tregister;_op2 : tlocation);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=top_reg;
+         size:=_size;
+         op1:=pointer(_op1);
+
+         if (_op2.loc=loc_register) or (_op2.loc=loc_cregister)  then
+           begin
+             opxt:=opxt+top_reg shl 4;
+             op2:=pointer(_op2.register);
+           end
+         else
+         if _op2.reference.isintvalue then
+           begin
+              opxt:=opxt+top_const shl 4;
+              op2:=pointer(_op2.reference.offset);
+           end
+         else
+           begin
+              opxt:=opxt+Top_ref shl 4;
+              op2:=pointer(newreference(_op2.reference));
+           end;
+
+      end;
+
+    constructor tai386.op_loc_reg(op : tasmop;_size : topsize;_op1 : tlocation;_op2 : tregister);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=top_reg shl 4;
+         size:=_size;
+         op2:=pointer(_op2);
+
+         if (_op1.loc=loc_register) or (_op1.loc=loc_cregister)  then
+           begin
+             opxt:=opxt+top_reg;
+             op1:=pointer(_op1.register);
+           end
+         else
+         if _op1.reference.isintvalue then
+           begin
+              opxt:=opxt+top_const;
+              op1:=pointer(_op1.reference.offset);
+           end
+         else
+           begin
+              opxt:=opxt+top_ref;
+              op1:=pointer(newreference(_op1.reference));
+           end;
+
+      end;
+
+    constructor tai386.op_const_reg_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister;_op3 : tregister);
+
+    type    twowords=record
+                word1,word2:word;
+            end;
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=Top_const+Top_reg shl 4+Top_reg shl 8;
+         size:=_size;
+         op1:=pointer(_op1);
+         twowords(op2).word1:=word(_op2);
+         twowords(op2).word2:=word(_op3);
+      end;
+
+    constructor tai386.op_const_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         if (op=A_CMP) and (_size=S_B) and
+            ((_op2<R_AL) or (_op2>R_DH)) then
+           begin
+{$ifdef extdebug}
+              comment(v_warning,'wrong size for A_CMP due to implicit size extension !!');
+{$endif extdebug}
+              _size:=S_L;
+           end;
+         opxt:=Top_const+Top_reg shl 4;
+         size:=_size;
+         op1:=pointer(_op1);
+         op2:=pointer(_op2);
+
+      end;
+
+    constructor tai386.op_const_const(op : tasmop;_size : topsize;_op1,_op2 : longint);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=Top_const+Top_const shl 4;
+         size:=_size;
+         op1:=pointer(_op1);
+         op2:=pointer(_op2);
+
+      end;
+
+    constructor tai386.op_const_ref(op : tasmop;_size : topsize;_op1 : longint;_op2 : preference);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=top_const;
+         size:=_size;
+         op1:=pointer(_op1);
+
+         if _op2^.isintvalue then
+           begin
+              opxt:=opxt+top_const shl 4;
+              op2:=pointer(_op2^.offset);
+           end
+         else
+           begin
+              opxt:=opxt+top_ref shl 4;
+              op2:=pointer(_op2);
+           end;
+
+      end;
+
+    constructor tai386.op_const_loc(op : tasmop;_size : topsize;_op1 : longint;_op2 : tlocation);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=top_const;
+         size:=_size;
+         op1:=pointer(_op1);
+
+         if (_op2.loc=loc_register) or (_op2.loc=loc_cregister)  then
+           begin
+             opxt:=opxt+Top_reg shl 4;
+             op2:=pointer(_op2.register);
+           end
+         else
+         if _op2.reference.isintvalue then
+           begin
+              opxt:=opxt+top_const shl 4;
+              op2:=pointer(_op2.reference.offset);
+           end
+         else
+           begin
+              opxt:=opxt+top_ref shl 4;
+              op2:=pointer(newreference(_op2.reference));
+           end;
+
+      end;
+
+    constructor tai386.op_ref_reg(op : tasmop;_size : topsize;_op1 : preference;_op2 : tregister);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=top_reg shl 4;
+         size:=_size;
+         op2:=pointer(_op2);
+
+         if _op1^.isintvalue then
+           begin
+              opxt:=opxt+top_const;
+              op1:=pointer(_op1^.offset);
+           end
+         else
+           begin
+              opxt:=opxt+top_ref;
+              op1:=pointer(_op1);
+           end;
+
+      end;
+
+    constructor tai386.op_ref_ref(op : tasmop;_size : topsize;_op1,_op2 : preference);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         size:=_size;
+
+         if _op1^.isintvalue then
+           begin
+              opxt:=top_const;
+              op1:=pointer(_op1^.offset);
+           end
+         else
+           begin
+              opxt:=top_ref;
+              op1:=pointer(_op1);
+           end;
+
+         if _op2^.isintvalue then
+           begin
+              opxt:=opxt+top_const shl 4;
+              op2:=pointer(_op2^.offset);
+           end
+         else
+           begin
+              opxt:=opxt+top_ref shl 4;
+              op2:=pointer(_op2);
+           end;
+
+      end;
+
+    constructor tai386.op_csymbol(op : tasmop;_size : topsize;_op1 : pcsymbol);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         if (op=A_CALL) and (use_esp_stackframe) then
+          Message(cg_e_stackframe_with_esp);
+         opxt:=top_symbol;
+         size:=_size;
+         op1:=pointer(_op1);
+         op2:=nil;
+      end;
+
+    constructor tai386.op_csymbol_reg(op : tasmop;_size : topsize;_op1 : pcsymbol;_op2 : tregister);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=Top_symbol+Top_reg shl 4;
+         size:=_size;
+         op1:=pointer(_op1);
+         op2:=pointer(_op2);
+
+      end;
+
+    constructor tai386.op_csymbol_ref(op : tasmop;_size : topsize;_op1 : pcsymbol;_op2 : preference);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=top_symbol;
+         size:=_size;
+         op1:=pointer(_op1);
+
+         if _op2^.isintvalue then
+           begin
+              opxt:=opxt+top_const shl 4;
+              op2:=pointer(_op2^.offset);
+           end
+         else
+           begin
+              opxt:=opxt+top_ref shl 4;
+              op2:=pointer(_op2);
+           end;
+
+      end;
+
+    constructor tai386.op_csymbol_loc(op : tasmop;_size : topsize;_op1 : pcsymbol;_op2 : tlocation);
+
+      begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=top_symbol;
+         size:=_size;
+         op1:=pointer(_op1);
+
+         if (_op2.loc=loc_register) or (_op2.loc=loc_cregister)  then
+           begin
+             opxt:=top_reg shl 4;
+             op2:=pointer(_op2.register);
+           end
+         else
+         if _op2.reference.isintvalue then
+           begin
+              opxt:=opxt+top_const shl 4;
+              op2:=pointer(_op2.reference.offset);
+           end
+         else
+           begin
+              opxt:=opxt+top_ref shl 4;
+              op2:=pointer(newreference(_op2.reference));
+           end;
+
+      end;
+
+    constructor tai386.op_reg_const(op:tasmop; _size: topsize; _op1: tregister; _op2: longint);
+    begin
+         inherited init;
+         typ:=ait_instruction;
+         _operator:=op;
+         opxt:=top_reg+top_const shl 4;
+         size:=_size;
+         op1:=pointer(_op1);
+         op2:=pointer(_op2);
+    end;
+
+   function Tai386.op1t:byte;
+
+    begin
+        op1t:=opxt and 15;
+    end;
+
+   function Tai386.op2t:byte;
+
+    begin
+        op2t:=(opxt shr 4) and 15;
+    end;
+
+   function Tai386.op3t:byte;
+
+    begin
+        op3t:=(opxt shr 8) and 15;
+    end;
+
+   destructor tai386.done;
+
+     begin
+        if op1t=top_symbol then
+          disposecsymbol(pcsymbol(op1))
+        else if op1t=top_ref then
+          begin
+             clear_reference(preference(op1)^);
+             dispose(preference(op1));
+          end;
+        if op2t=top_symbol then
+          disposecsymbol(pcsymbol(op2))
+        else if op2t=top_ref then
+          begin
+             clear_reference(preference(op2)^);
+             dispose(preference(op2));
+          end;
+     end;
+
+{****************************************************************************
+                             TAI_LABELED
+ ****************************************************************************}
+
+    constructor tai_labeled.init(op : tasmop; l : plabel);
+
+      begin
+         inherited init;
+         typ:=ait_labeled_instruction;
+         _operator:=op;
+         lab:=l;
+         lab^.is_used:=true;
+         inc(lab^.refcount);
+      end;
+
+    destructor tai_labeled.done;
+
+      begin
+         dec(lab^.refcount);
+         if lab^.refcount=0 then
+           Begin
+             lab^.is_used := False;
+             If Not(lab^.is_set) Then
+               Dispose(lab);
+           End;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:13  root
+  Initial revision
+
+  Revision 1.21  1998/03/10 16:27:39  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:19  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:11  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/06 00:52:19  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.17  1998/03/02 01:48:38  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.16  1998/02/28 00:20:25  florian
+    * more changes to get import libs for Win32 working
+
+  Revision 1.15  1998/02/25 12:32:16  daniel
+  * Compiler uses even less memory.
+
+  Revision 1.14  1998/02/13 10:35:06  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.13  1998/02/12 17:19:04  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.12  1998/02/12 11:50:08  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.11  1998/02/04 22:01:59  florian
+    + S_D for MMX MOVD added, but unused
+
+  Revision 1.10  1998/01/16 22:34:33  michael
+  * Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
+    in this compiler :)
+
+  Revision 1.9  1997/12/13 18:59:46  florian
+  + I/O streams are now also declared as external, if neccessary
+  * -Aobj generates now a correct obj file via nasm
+
+  Revision 1.8  1997/12/09 13:42:09  carl
+  * bugfix of lab2str with nasm output
+    (. = local label in nasm, which would cause some problems sometimes)
+  * bugfix of out reg,imm8 (missing instruction template)
+  + renamed pai_labeled386 --> pai_labeled
+  + added extended size constant
+
+  Revision 1.7  1997/12/08 11:43:43  pierre
+     * syntax error in previous commit
+
+  Revision 1.6  1997/12/08 10:12:05  pierre
+     * bug fix for cmpb for a value in the range 129-255 :
+       if the destination is a word or lognint reg then there is an implicit sign
+       extension of the const (thus becoming -127 to -1)
+     + redefined ao_floatreg to include the floatacc (used in ratti386.pas)
+
+  Revision 1.5  1997/11/28 23:46:09  florian
+  LOC_CMMXREGISTER added
+
+  Revision 1.4  1997/11/28 19:56:41  carl
+  * forgot dtou!
+
+  Revision 1.3  1997/11/28 18:15  pierre
+   working version with several bug fixes
+
+  Revision 1.2  1997/11/28 14:53:38  carl
+  + added popad,popfd,pushad,pushfd in op table.
+
+  Revision 1.1.1.1  1997/11/27 08:32:56  michael
+  FPC Compiler CVS start
+
+  Pre-CVS log:
+
+  FK     Florian Klaempfl
+  PM     Pierre Muller
+  +      feature added
+  -      removed
+  *      bug fixed or changed
+
+  History:
+      30th september 1996:
+         + unit started
+      15th october 1996:
+         + tai386 added
+         + some code from asmgen moved to this unit
+      26th november 1996:
+         + tai386_labeled
+      15th october 1997:
+         + lab2str increments also refcount (FK)
+      6th november 1997:
+         * added S_T for s80real fldt and fstpt (PM)
+      20th november 1997:
+         * changed LOC_FPUSTACK to LOC_FPU for compatibility with m68k (PM)
+
+}

compiler/import.pas

@@ -0,0 +1,99 @@
+{
+    $Id$
+    Copyright (c) 1998 by Peter Vreman
+
+    This unit implements an uniform import object
+
+    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 import;
+interface
+
+type
+  pimportlib=^timportlib;
+  timportlib=object
+    constructor Init;
+    destructor Done;
+    procedure preparelib(const s:string);virtual;
+    procedure importprocedure(const func,module:string;index:longint;const name:string);virtual;
+    procedure generatelib;virtual;
+  end;
+var
+  importlib : pimportlib;
+
+procedure InitImport;
+
+implementation
+
+uses
+  systems,verbose,
+  os2_targ,win_targ;
+
+constructor timportlib.Init;
+begin
+end;
+
+
+destructor timportlib.Done;
+begin
+end;
+
+
+procedure timportlib.preparelib(const s:string);
+begin
+  Message(exec_e_dll_not_supported);
+end;
+
+
+procedure timportlib.importprocedure(const func,module:string;index:longint;const name:string);
+begin
+  Message(exec_e_dll_not_supported);
+end;
+
+
+procedure timportlib.generatelib;
+begin
+  Message(exec_e_dll_not_supported);
+end;
+
+
+procedure InitImport;
+begin
+  case target_info.target of
+ target_Win32 : importlib:=new(pimportlibwin32,Init);
+   target_OS2 : importlib:=new(pimportlibos2,Init);
+  else
+   importlib:=new(pimportlib,Init);
+  end;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:12  root
+  Initial revision
+
+  Revision 1.3  1998/03/10 01:17:19  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.2  1998/03/06 00:52:21  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+}

compiler/innr.inc

@@ -0,0 +1,81 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library and compiler.
+    Copyright (c) 1993,98 by the Free Pascal development team
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+
+const
+   in_lo_word = 1;
+   in_hi_word = 2;
+   in_lo_long = 3;
+   in_hi_long = 4;
+   { to be able to compile with ord intern or not }
+   in_ord_char = 5;
+   in_ord_x = 5;
+   in_length_string = 6;
+   in_chr_byte = 7;
+   in_inc_byte = 8;
+   in_inc_word = 9;
+   in_inc_dword = 10;
+   in_dec_byte = 11;
+   in_dec_word = 12;
+   in_dec_dword = 13;
+   in_write_x = 14;
+   in_writeln_x = 15;
+   in_read_x = 16;
+   in_readln_x = 17;
+   in_concat_x = 18;
+   in_assigned_x = 19;
+   in_str_x_string = 20;
+   in_ofs_x = 21;
+   in_sizeof_x = 22;
+   in_typeof_x = 23;
+   in_val_x = 24;
+   in_reset_x = 25;
+   in_rewrite_x = 26;
+   in_low_x = 27;
+   in_high_x = 28;
+   in_seg_x = 29;
+   in_pred_x = 30;
+   in_succ_x = 31;
+   in_reset_typedfile = 32;
+   in_rewrite_typedfile = 33;
+   in_settextbuf_file_x = 34;
+   in_inc_x = 35;
+   in_dec_x = 36;
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:12  root
+  Initial revision
+
+  Revision 1.2  1998/02/24 16:50:03  peter
+    * stackframe ommiting generated 'ret $-4'
+    + timer.pp bp7 version
+    * innr.inc are now the same files
+
+  Revision 1.3  1998/01/26 11:59:37  michael
+  + Added log at the end
+
+  revision 1.2
+  date: 1997/12/01 12:08:04;  author: michael;  state: Exp;  lines: +8 -17
+  + added copyright reference header.
+  ----------------------------
+  revision 1.1
+  date: 1997/11/27 08:33:46;  author: michael;  state: Exp;
+  Initial revision
+  ----------------------------
+  revision 1.1.1.1
+  date: 1997/11/27 08:33:46;  author: michael;  state: Exp;  lines: +0 -0
+  FPC RTL CVS start
+  =============================================================================
+}
+

compiler/link.pas

@@ -0,0 +1,517 @@
+{
+    $Id$
+    Copyright (c) 1998 by the FPC development team
+
+    This unit handles the linker and binder calls for programs and
+    libraries
+
+    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 link;
+
+Interface
+
+uses cobjects;
+
+Type TLinker = Object
+     { Internal variables. Don't access directly }
+       {$ifdef linux}
+       LinkToC : Boolean;                 { Should we link to the C libs? }
+       GccLibraryPath : String;           { Where is GCCLIB ? }
+       DynamicLinker : String;            { What Dynamic linker ? }
+       {$endif}
+       OFiles, LibFiles : TStringContainer;
+       Strip : Boolean;                   { Strip symbols ? }
+       MakeLib : Boolean;                 { If unit : Make library ?}
+       ExeName,                           { FileName of the exe to be created }
+       LibName     : String;              { FileName of the lib to be created }
+       LinkResName : String[32];          { Name of response file }
+       LinkOptions : String;              { Additional options to the linker }
+       LibrarySearchPath : String;        { Where to look for libraries }
+     { Methods }
+       Constructor Init;
+       Procedure SetFileName(const s:string);
+       function  FindObjectFile(s : string) : string;
+       Procedure AddLibraryFile(S : String);
+       Procedure AddObjectFile(S : String);
+       Function  FindLinker : String;      { Find linker, sets Name }
+       Function  DoExec(const command,para:string):boolean;
+       Function  WriteResponseFile : Boolean;
+       Function  Link:boolean;
+       Procedure Make_Library;
+     end;
+     PLinker=^TLinker;
+
+Var Linker : TLinker;
+
+
+Implementation
+
+uses
+  Script,globals,systems,dos,verbose;
+
+Constructor TLinker.Init;
+begin
+  OFiles.Init;
+  LibFiles.Init;
+  OFiles.Doubles:=False;
+  LibFiles.Doubles:=False;
+  Strip:=false;
+  LinkOptions:='';
+  LinkResName:='link.res';
+  ExeName:='';
+  LibName:='';
+{$ifdef linux}
+  LinkToC:=False;
+  LibrarySearchPath:='';
+  DynamicLinker:='/lib/ld-linux.so.1';
+{$endif}
+end;
+
+
+Procedure TLinker.SetFileName(const s:string);
+var
+  path:dirstr;
+  name:namestr;
+  ext:extstr;
+begin
+  FSplit(s,path,name,ext);
+  LibName:=Path+Name+target_info.DllExt;
+  ExeName:=Path+Name+target_info.ExeExt;
+end;
+
+
+var
+  LastLDBin : string;
+Function TLinker.FindLinker:string;
+var
+  ldfound : boolean;
+begin
+  if LastLDBin='' then
+   begin
+     if (target_info.target=target_WIN32) then
+     { the win32 linker has another name to allow cross compiling between }
+     { DOS and Win32, I think it should be possible to compile an ld      }
+     { with handles coff and pe, but I don't know how      (FK)           }
+       LastLDBin:=FindExe('ldw',ldfound)
+     else
+       LastLDBin:=FindExe('ld',ldfound);
+     if (not ldfound) and (not externlink) then
+      begin
+        Message1(exec_w_linker_not_found,LastLDBin);
+        externlink:=true;
+      end;
+     if ldfound then
+      Message1(exec_u_using_linker,LastLDBin);
+   end;
+  FindLinker:=LastLDBin;
+end;
+
+
+{ searches an object file }
+function TLinker.FindObjectFile(s:string) : string;
+var
+  found : boolean;
+begin
+  if pos('.',s)=0 then
+   s:=s+target_info.objext;
+  s:=FixFileName(s);
+  if FileExists(s) then
+   begin
+     Findobjectfile:=s;
+     exit;
+   end;
+  findobjectfile:=search(s,'.;'+unitsearchpath+';'+exepath,found)+s;
+  if (not externasm) and (not found) then
+   Message1(exec_e_objfile_not_found,s);
+end;
+
+
+Procedure TLInker.AddObjectFile (S : String);
+begin
+  if pos('.',s)=0 then
+   s:=s+target_info.objext;
+  s:=FixFileName(s);
+  OFiles.Insert (S);
+end;
+
+
+Procedure TLInker.AddLibraryFile(S:String);
+begin
+  if pos('.',s)=0 then
+   s:=s+target_info.dllext;
+  s:=FixFileName(s);
+  LibFiles.Insert (S);
+end;
+
+
+Function TLinker.DoExec(const command,para:string):boolean;
+begin
+  DoExec:=true;
+  if not externlink then
+   begin
+     swapvectors;
+     exec(command,para);
+     swapvectors;
+     if (dosexitcode<>0) then
+      begin
+        Message(exec_w_error_while_linking);
+        DoExec:=false;
+        exit;
+      end
+     else
+      if (dosError<>0) then
+       begin
+         Message(exec_w_cant_call_linker);
+         ExternLink:=true;
+       end;
+   end;
+  if externlink then
+   AsmRes.AddLinkCommand (Command,Para,ExeName);
+end;
+
+
+Function TLinker.WriteResponseFile : Boolean;
+Var
+  LinkResponse : Text;
+  i            : longint;
+  prtobj,s     : string;
+begin
+{ Open linkresponse and write header }
+  assign(linkresponse,inputdir+LinkResName);
+  rewrite(linkresponse);
+
+{ Write Header and set runtime object (prt0) }
+  case target_info.target of
+   target_WIN32 : begin
+                    prtobj:='';
+                    writeln(linkresponse,'INPUT (');
+                  end;
+   target_linux : begin
+                    if cs_profile in aktswitches then
+                     prtobj:='gprt0'
+                    else
+                     prtobj:='prt0';
+{$ifdef Linux}
+                    if LinkToC then
+                     writeln(linkresponse,'SEARCH_DIR ('+GCCLibraryPath +')');
+{$endif}
+                    writeln(linkresponse,'INPUT (');
+                  end;
+  else
+   prtobj:='prt0';
+  end;          
+
+{ add objectfiles, start with prt0 always }
+  if prtobj<>'' then
+   Writeln(linkresponse,FindObjectFile(prtobj));
+  while not OFiles.Empty do
+   begin
+     s:=Findobjectfile(OFiles.Get);
+     if s<>'' then
+      Writeln(linkresponse,s);
+   end;
+
+{ Write libraries like -l<lib> }
+  While not LibFiles.Empty do
+   begin
+     S:=LibFiles.Get;
+     i:=Pos(target_info.dllext,S);
+     if i>0 then
+      Delete(S,i,255);
+     Writeln (LinkResponse,'-l'+S);
+   end;
+
+{ Write End of response file }
+  if target_info.target in [target_WIN32,target_linux] then
+    Writeln (LinkResponse,')');
+
+{ Close response }
+  close(linkresponse);
+  WriteResponseFile:=True;
+end;
+
+
+Function TLinker.link:boolean;
+var
+  bindbin    : string[80];
+  bindfound  : boolean;
+  _stacksize,i,
+  _heapsize  : longint;
+  s,s2       : string[10];
+  dummy      : file;
+  success    : boolean;
+begin
+{$ifdef linux}
+  if LinkToC then
+   begin
+     AddObjectFile('/usr/lib/crt0.o');
+     AddObjectFile(FindObjectFile('lprt'));
+     AddLibraryFile('libc.a');
+     AddLibraryFile('libgcc.a');
+   end;
+{$endif Linux}
+
+{ Create Linkoptions }
+  case target_info.target of
+     target_GO32V1:
+       LinkOptions:=LinkOptions+' -oformat coff-go32';
+     target_GO32V2:
+       LinkOptions:=LinkOptions+' -oformat coff-go32-exe';
+      target_linux: begin
+                      if cs_profile in aktswitches then
+                       begin
+                         AddLibraryFile('gmon');
+                         AddLibraryFile('c');
+                       end;     
+                    end;
+  end;
+
+{$ifdef linux}
+  If not LibFiles.Empty then
+   LinkOptions:='-dynamic-linker='+DynamicLinker+' '+LinkOptions;
+{$endif linux}
+
+  if Strip then
+   LinkOptions:=LinkOptions+' -s';
+
+{ Write used files and libraries }
+  WriteResponseFile;
+
+{ Call linker }
+  if not externlink then
+   Message1(exec_i_linking,ExeName);
+{$ifdef linux}
+  success:=DoExec(FindLinker,LinkOptions+' -o '+exename+' '+inputdir+LinkResName);
+{$else}
+  if target_info.target=target_WIN32 then
+    success:=DoExec(FindLinker,LinkOptions+' -o '+exename+' '+inputdir+LinkResName)
+  else
+    success:=DoExec(FindLinker,LinkOptions+' -o '+exename+' @'+inputdir+LinkResName);
+{$endif}
+
+{Bind}
+  if target_info.target=target_os2 then
+   begin
+   {Calculate the stack and heap size in kilobytes, rounded upwards.}
+     _stacksize:=(stacksize+1023) shr 10;
+   {Minimum stacksize for EMX is 32K.}
+     if _stacksize<32 then
+      _stacksize:=32;
+     str(_stacksize,s);
+     _heapsize:=(heapsize+1023) shr 10;
+     str(_heapsize,s2);
+     bindbin:=FindExe('emxbind',bindfound);
+     if (not bindfound) and (not externlink) then
+      begin
+        Message(exec_w_binder_not_found);
+        externlink:=true;
+      end;
+     DoExec(bindbin,'-k'+s+' -o '+exename+'.exe '+exename+' -aim -s'+s2);
+   end;
+  if (success) and (not externlink) then
+   begin
+     assign(dummy,LinkResName);
+     {$I-}
+      erase(dummy);
+     {$I+}
+     i:=ioresult;
+   end;
+  link:=success;   { otherwise a recursive call to link method }
+end;
+
+
+Procedure TLinker.Make_Library;
+var
+{$ifndef linux}
+  arbin : string;
+  arfound : boolean;
+{$endif}
+begin
+  if cs_shared_lib in initswitches then
+   begin
+     WriteResponseFile;
+{$ifdef linux}
+     DoExec(FindLinker,' -o '+libname+'.so -shared link.res');
+{$else}
+     arbin:=FindExe('ar',arfound);
+     if (not arfound) and (not externlink) then
+      begin
+        Message(exec_w_ar_not_found);
+        externlink:=true;
+      end;
+     DoExec(arbin,'rs '+libname+'.a');
+{$endif}
+   end;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:13  root
+  Initial revision
+
+  Revision 1.31  1998/03/13 22:45:58  florian
+    * small bug fixes applied
+
+  Revision 1.30  1998/03/11 22:22:52  florian
+    * Fixed circular unit uses, when the units are not in the current dir (from Peter)
+    * -i shows correct info, not <lf> anymore (from Peter)
+    * linking with shared libs works again (from Peter)
+
+  Revision 1.29  1998/03/10 16:27:39  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.28  1998/03/10 01:17:19  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.27  1998/03/05 22:43:47  florian
+    * some win32 support stuff added
+
+  Revision 1.26  1998/03/04 01:35:04  peter
+    * messages for unit-handling and assembler/linker
+    * the compiler compiles without -dGDB, but doesn't work yet
+    + -vh for Hint
+
+  Revision 1.25  1998/03/02 01:48:42  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.24  1998/03/01 22:46:12  florian
+    + some win95 linking stuff
+    * a couple of bugs fixed:
+      bug0055,bug0058,bug0059,bug0064,bug0072,bug0093,bug0095,bug0098
+
+  Revision 1.23  1998/02/28 03:56:15  carl
+    + replaced target_info.short_name by target_info.target (a bit faster)
+
+  Revision 1.22  1998/02/26 11:57:09  daniel
+  * New assembler optimizations commented out, because of bugs.
+  * Use of dir-/name- and extstr.
+
+  Revision 1.21  1998/02/25 20:26:41  michael
+  + fixed linking for linux
+
+  Revision 1.20  1998/02/24 14:20:53  peter
+    + tstringcontainer.empty
+    * ld -T option restored for linux
+    * libraries are placed before the objectfiles in a .PPU file
+    * removed 'uses link' from files.pas
+
+  Revision 1.19  1998/02/23 02:54:23  carl
+    * bugfix of recusrive call to link
+
+  Revision 1.18  1998/02/22 23:03:18  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.17  1998/02/19 00:11:00  peter
+    * fixed -g to work again
+    * fixed some typos with the scriptobject
+
+  Revision 1.16  1998/02/18 13:48:16  michael
+  + Implemented an OS independent AsmRes object.
+
+  Revision 1.15  1998/02/18 08:55:26  michael
+  * Removed double declaration of LinkerOptions
+
+  Revision 1.14  1998/02/17 21:20:50  peter
+    + Script unit
+    + __EXIT is called again to exit a program
+    - target_info.link/assembler calls
+    * linking works again for dos
+    * optimized a few filehandling functions
+    * fixed stabs generation for procedures
+
+  Revision 1.13  1998/02/16 13:46:40  michael
+  + Further integration of linker object:
+    - all options pertaining to linking go directly to linker object
+    - removed redundant variables/procedures, especially in OS_TARG...
+
+  Revision 1.12  1998/02/16 12:51:31  michael
+  + Implemented linker object
+
+  Revision 1.11  1998/02/15 21:16:21  peter
+    * all assembler outputs supported by assemblerobject
+    * cleanup with assembleroutputs, better .ascii generation
+    * help_constructor/destructor are now added to the externals
+    - generation of asmresponse is not outputformat depended
+
+  Revision 1.10  1998/02/14 01:45:21  peter
+    * more fixes
+    - pmode target is removed
+    - search_as_ld is removed, this is done in the link.pas/assemble.pas
+    + findexe() to search for an executable (linker,assembler,binder)
+
+  Revision 1.9  1998/02/13 22:26:28  peter
+    * fixed a few SigSegv's
+    * INIT$$ was not written for linux!
+    * assembling and linking works again for linux and dos
+    + assembler object, only attasmi3 supported yet
+    * restore pp.pas with AddPath etc.
+
+  Revision 1.8  1998/02/13 10:35:09  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+>>>>>>> h:/cvs/compiler/link.pas
+  Revision 1.7  1998/02/02 00:55:32  peter
+    * defdatei -> deffile and some german comments to english
+    * search() accepts : as seperater under linux
+    * search for ppc.cfg doesn't open a file (and let it open)
+    * reorganize the reading of parameters/file a bit
+    * all the PPC_ environments are now for all platforms
+
+  Revision 1.6  1998/02/01 15:02:11  florian
+    * swapvectors around exec inserted
+
+  Revision 1.5  1998/01/28 13:48:39  michael
+  + Initial implementation for making libs from within FPC. Not tested, as compiler does not run
+
+  Revision 1.4  1998/01/25 18:45:43  peter
+    + Search for as and ld at startup
+    + source_info works the same as target_info
+    + externlink allows only external linking
+
+  Revision 1.3  1998/01/24 00:36:07  florian
+    + small fix to get it working with DOS (dynamiclinker isn't declared for dos)
+
+  Revision 1.2  1998/01/23 22:19:17  michael
+  + Implemented setting of dynamic linker name (linux only).
+    Declared Make_library
+    -Fd switch sets linker (linux only)
+  * Reinstated -E option of Pierre
+
+  Revision 1.1  1998/01/23 17:57:41  michael
+  + Initial implementation.
+
+}

compiler/m68k.pas

@@ -0,0 +1,1723 @@
+{
+    $Id$
+    Copyright (c) 1995-98 by Florian Klaempfl, Carl Eric Codere
+
+    This unit implements an types and classes specific for the
+    MC68000/MC68020
+
+    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 m68k;
+
+  interface
+
+    uses
+       strings,systems,cobjects,globals,aasm,verbose;
+
+    const
+      { if real fpu is used }
+      { otherwise maps to   }
+      { s32real.            }
+      extended_size = 12;
+
+
+    type
+    {  warning: CPU32 opcodes are not fully compatible with the MC68020. }
+       { 68000 only opcodes }
+       tasmop = (A_ABCD,
+         A_ADD,A_ADDA,A_ADDI,A_ADDQ,A_ADDX,A_AND,A_ANDI,
+         A_ASL,A_ASR,A_BCC,A_BCS,A_BEQ,A_BGE,A_BGT,A_BHI,
+         A_BLE,A_BLS,A_BLT,A_BMI,A_BNE,A_BPL,A_BVC,A_BVS,
+         A_BCHG,A_BCLR,A_BRA,A_BSET,A_BSR,A_BTST,A_CHK,
+         A_CLR,A_CMP,A_CMPA,A_CMPI,A_CMPM,A_DBCC,A_DBCS,A_DBEQ,A_DBGE,
+         A_DBGT,A_DBHI,A_DBLE,A_DBLS,A_DBLT,A_DBMI,A_DBNE,A_DBRA,
+         A_DBPL,A_DBT,A_DBVC,A_DBVS,A_DBF,A_DIVS,A_DIVU,
+         A_EOR,A_EORI,A_EXG,A_ILLEGAL,A_EXT,A_JMP,A_JSR,
+         A_LEA,A_LINK,A_LSL,A_LSR,A_MOVE,A_MOVEA,A_MOVEI,A_MOVEQ,
+         A_MOVEM,A_MOVEP,A_MULS,A_MULU,A_NBCD,A_NEG,A_NEGX,
+         A_NOP,A_NOT,A_OR,A_ORI,A_PEA,A_ROL,A_ROR,A_ROXL,
+         A_ROXR,A_RTR,A_RTS,A_SBCD,A_SCC,A_SCS,A_SEQ,A_SGE,
+         A_SGT,A_SHI,A_SLE,A_SLS,A_SLT,A_SMI,A_SNE,
+         A_SPL,A_ST,A_SVC,A_SVS,A_SF,A_SUB,A_SUBA,A_SUBI,A_SUBQ,
+         A_SUBX,A_SWAP,A_TAS,A_TRAP,A_TRAPV,A_TST,A_UNLK,
+         A_RTE,A_RESET,A_STOP,
+         { MC68010 instructions }
+         A_BKPT,A_MOVEC,A_MOVES,A_RTD,
+         { MC68020 instructions }
+         A_BFCHG,A_BFCLR,A_BFEXTS,A_BFEXTU,A_BFFFO,
+         A_BFINS,A_BFSET,A_BFTST,A_CALLM,A_CAS,A_CAS2,
+         A_CHK2,A_CMP2,A_DIVSL,A_DIVUL,A_EXTB,A_PACK,A_RTM,
+         A_TRAPCC,A_TRACS,A_TRAPEQ,A_TRAPF,A_TRAPGE,A_TRAPGT,
+         A_TRAPHI,A_TRAPLE,A_TRAPLS,A_TRAPLT,A_TRAPMI,A_TRAPNE,
+         A_TRAPPL,A_TRAPT,A_TRAPVC,A_TRAPVS,A_UNPK,
+         { FPU Processor instructions - directly supported only. }
+         { IEEE aware and misc. condition codes not supported   }
+         A_FABS,A_FADD,
+         A_FBEQ,A_FBNE,A_FBNGT,A_FBGT,A_FBGE,A_FBNGE,
+         A_FBLT,A_FBNLT,A_FBLE,A_FBGL,A_FBNGL,A_FBGLE,A_FBNGLE,
+         A_FDBEQ,A_FDBNE,A_FDBGT,A_FDBNGT,A_FDBGE,A_FDBNGE,
+         A_FDBLT,A_FDBNLT,A_FDBLE,A_FDBGL,A_FDBNGL,A_FDBGLE,A_FBDNGLE,
+         A_FSEQ,A_FSNE,A_FSGT,A_FSNGT,A_FSGE,A_FSNGE,
+         A_FSLT,A_FSNLT,A_FSLE,A_FSGL,A_FSNGL,A_FSGLE,A_FSNGLE,
+         A_FCMP,A_FDIV,A_FMOVE,A_FMOVEM,
+         A_FMUL,A_FNEG,A_FNOP,A_FSQRT,A_FSUB,A_FSGLDIV,
+         A_FSFLMUL,A_FTST,
+         A_FTRAPEQ,A_FTRAPNE,A_FTRAPGT,A_FTRAPNGT,A_FTRAPGE,A_FTRAPNGE,
+         A_FTRAPLT,A_FTRAPNLT,A_FTRAPLE,A_FTRAPGL,A_FTRAPNGL,A_FTRAPGLE,A_FTRAPNGLE,
+         { Protected instructions }
+         A_CPRESTORE,A_CPSAVE,
+         { FPU Unit protected instructions                    }
+         { and 68030/68851 common MMU instructions            }
+         { (this may include 68040 MMU instructions)          }
+         A_FRESTORE,A_FSAVE,A_PFLUSH,A_PFLUSHA,A_PLOAD,A_PMOVE,A_PTEST,
+         { Useful for assembly langage output }
+         A_LABEL,A_NONE);
+
+       { enumeration for registers, don't change the }
+       { order of this table                         }
+       { Registers which can and will be used by the compiler }
+       tregister = (
+         R_NO,R_D0,R_D1,R_D2,R_D3,R_D4,R_D5,R_D6,R_D7,
+         R_A0,R_A1,R_A2,R_A3,R_A4,R_A5,R_A6,R_SP,
+         { PUSH/PULL- quick and dirty hack }
+         R_SPPUSH,R_SPPULL,
+         { misc. }
+         R_CCR,R_FP0,R_FP1,R_FP2,R_FP3,R_FP4,R_FP5,R_FP6,
+         R_FP7,R_FPCR,R_SR,R_SSP,R_DFC,R_SFC,R_VBR,R_FPSR,
+         { other - not used in reg2str }
+         R_DEFAULT_SEG);
+
+       { S_NO = No Size of operand }
+       { S_B  = Byte size operand  }
+       { S_W  = Word size operand  }
+       { S_L  = DWord size operand }
+       { USED FOR conversions in x86}
+       { S_BW = Byte to word       }
+       { S_BL = Byte to long       }
+       { S_WL = Word to long       }
+       { Floating point types      }
+       { S_X  = Extended type      }
+       { S_Q  = double/64bit integer }
+       { S_S  = single type (32 bit) }
+       topsize = (S_NO,S_B,S_W,S_L,S_BW,S_BL,S_WL,S_Q,S_S,S_X);
+
+       plocation = ^tlocation;
+
+       { information about the location of an operand }
+       { LOC_FPU         FPU registers = Dn if emulation }
+       { LOC_REGISTER    in a processor register }
+       { LOC_MEM         in the memory }
+       { LOC_REFERENCE   like LOC_MEM, but lvalue }
+       { LOC_JUMP        nur bool'sche Resultate, Sprung zu false- oder }
+       {                 truelabel }
+       { LOC_FLAGS       nur bool'sche Rsultate, Flags sind gesetzt }
+       { LOC_CREGISTER   register which shouldn't be modified }
+       { LOC_INVALID     added for tracking problems}
+
+       tloc = (LOC_INVALID,LOC_FPU,LOC_REGISTER,LOC_MEM,LOC_REFERENCE,LOC_JUMP,
+           LOC_FLAGS,LOC_CREGISTER);
+
+       tregisterlist = set of tregister;
+
+ { F_E = Equal
+   F_NE = Not Equal
+   F_G = Greater then
+   F_L = Less then
+   F_GE = Greater or equal then
+   F_LE = Less or equal then
+   F_C = Carry
+   F_NC = Not Carry
+   F_A = Above
+   F_AE = Above or Equal
+   F_B = Below
+   F_BE = Below or Equal
+   other flags:
+   FL_xxx = floating type flags .
+
+ }
+       tresflags = (F_E,F_NE,F_G,F_L,F_GE,F_LE,F_C,F_NC,
+          F_A,F_AE,F_B,F_BE);
+          { floating type flags used by FBCC are auotmatically converted }
+          { to standard condition codes                                  }
+{          FL_E,FL_NE,FL_A,FL_AE,FL_B,FL_BE);}
+
+       preference = ^treference;
+
+      { direction of address register : }
+      {              (An)     (An)+   -(An)  }
+      tdirection = (dir_none,dir_inc,dir_dec);
+
+       treference = record
+      base,segment,index : tregister;
+      offset : longint;
+      symbol : pstring;
+      { indexed increment and decrement mode }
+      { (An)+ and -(An)                      }
+      direction : tdirection;
+      { a constant is also a treference, this makes the code generator }
+      { easier                                                         }
+      isintvalue : boolean;
+      scalefactor : byte;
+       end;
+
+       tlocation = record
+      case loc : tloc of
+         { segment in reference at the same place as in loc_register }
+         LOC_REGISTER,LOC_CREGISTER : (register,segment : tregister);
+         LOC_MEM,LOC_REFERENCE : (reference : treference);
+         LOC_FPU : (fpureg:tregister);
+         LOC_JUMP : ();
+         LOC_FLAGS : (resflags : tresflags);
+         LOC_INVALID : ();
+       end;
+
+       pcsymbol = ^tcsymbol;
+
+       tcsymbol = record
+      symbol : pchar;
+         offset : longint;
+       end;
+
+    const
+ {----------------------------------------------------------------------}
+ { F_E = Equal                                                          }
+ { F_NE = Not Equal                                                     }
+ { F_G = Greater then                                                   }
+ { F_L = Less then                                                      }
+ { F_GE = Greater or equal then                                         }
+ { F_LE = Less or equal then                                            }
+ { F_C = Carry                            = C                           }
+ { F_NC = Not Carry                       = not C                       }
+ { F_A = Above                            = not C and not Z             }
+ { F_AE = Above or Equal                  = not C                       }
+ { F_B = Below                            = C                           }
+ { F_BE = Below or Equal                  = C or Z                      }
+ { FL_E = Floating point equal            = Z                           }
+ { FL_NE = Floating point Not equal       = not Z                       }
+ { FL_A  = Floating point above           =                             }
+ { FL_AE = Floating point above or equal  =                             }
+ { FL_B  = Floating point below           =                             }
+ { FL_BE = Floating point below or equal  =                             }
+
+ { THE ORDER OF THIS TABLE SHOULD NOT BE CHANGED! }
+ flag_2_jmp: array[F_E..F_BE] of tasmop =
+ (A_BEQ,A_BNE,A_BGT,A_BLT,A_BGE,A_BLE,A_BCS,A_BCC,
+  A_BHI,A_BCC,A_BCS,A_BLS);
+  { floating point jumps - CURRENTLY NOT USED }
+{  A_FBEQ,A_FBNE,A_FBGT,A_FBGE,A_FBLT,A_FBLE); }
+
+ { don't change the order of this table, it is related to }
+ { the flags table.                                       }
+
+ flag_2_set: array[F_E..F_BE] of tasmop =
+ (A_SEQ,A_SNE,A_SGT,A_SLT,A_SGE,A_SLE,A_SCS,A_SCC,
+  A_SHI,A_SCC,A_SCS,A_SLS);
+
+
+       { operand types }
+       top_none = 0;
+       top_reg = 1;
+       top_ref = 2;
+       top_reglist = 5;
+
+       { a constant can be also written as treference }
+       top_const = 3;
+
+       { this is for calls }
+       top_symbol = 4;
+
+       {This constant is an alias for the stack pointer, as it's name may
+        differ from processor to processor.}
+       stack_pointer = R_SP;
+
+       frame_pointer = R_A6;
+
+       {This constant is an alias for the accumulator, as it's name may
+        differ from processor to processor.}
+       accumulator = R_D0;
+
+    type
+
+       pai_extended = ^tai_extended;
+
+       { generates an extended - processor specific }
+       tai_extended = object(tai)
+          value : bestreal;
+          constructor init(_value : bestreal);
+       end;
+
+       pai_comp = ^tai_comp;
+
+       { generates a comp - processor specific  }
+       tai_comp = object(tai)
+          value : bestreal;
+          constructor init(_value : bestreal);
+       end;
+
+       pai_labeled = ^tai_labeled;
+
+       tai_labeled = object(tai)
+          _operator : tasmop;
+          _op1: tregister;
+          lab : plabel;
+          constructor init(op : tasmop; l : plabel);
+          constructor init_reg(op: tasmop; l : plabel; reg: tregister);
+          destructor done;virtual;
+       end;
+
+       pai68k = ^tai68k;
+
+       tai68k = object(tai)
+      { this isn't a proper style, but not very memory expensive }
+      op1,op2,op3 : pointer;
+      _operator : tasmop;
+      op1t,op2t,op3t : byte;
+      size : topsize;
+     reglist: set of tregister;
+      constructor op_none(op : tasmop;_size : topsize);
+
+      constructor op_reg(op : tasmop;_size : topsize;_op1 : tregister);
+      constructor op_const(op : tasmop;_size : topsize;_op1 : longint);
+      constructor op_ref(op : tasmop;_size : topsize;_op1 : preference);
+      constructor op_loc(op : tasmop;_size : topsize;_op1 : tlocation);
+
+      constructor op_reg_reg(op : tasmop;_size : topsize;_op1,_op2 : tregister);
+      constructor op_reg_ref(op : tasmop;_size : topsize;_op1 : tregister;_op2 : preference);
+      constructor op_reg_loc(op : tasmop;_size : topsize;_op1 : tregister;_op2 : tlocation);
+      constructor op_loc_reg(op : tasmop;_size : topsize;_op1 : tlocation;_op2 : tregister);
+
+      constructor op_const_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister);
+      { this combination is needed by ENTER }
+      constructor op_const_const(op : tasmop;_size : topsize;_op1,_op2 : longint);
+      constructor op_const_ref(op : tasmop;_size : topsize;_op1 : longint;_op2 : preference);
+      constructor op_const_loc(op : tasmop;_size : topsize;_op1 : longint;_op2 : tlocation);
+
+      constructor op_ref_reg(op : tasmop;_size : topsize;_op1 : preference;_op2 : tregister);
+      { this is only allowed if _op1 is an int value (_op1^.isintvalue=true) }
+      constructor op_ref_ref(op : tasmop;_size : topsize;_op1,_op2 : preference);
+      {
+      constructor op_ref_loc(op : tasmop;_size : topsize;_op1 : preference;_op2 : tlcation);}
+
+      constructor op_const_reg_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister;_op3 : tregister);
+
+      { used by MC68020 mul/div }
+      constructor op_reg_reg_Reg(op: tasmop;_size: topsize;_op1: tregister; _op2: tregister; _op3: tregister);
+
+     { used by link }
+     constructor op_reg_const(op: tasmop; _size: topsize; _op1: tregister; _op2: longint);
+      { this is for CALL etc.                            }
+      { symbol is replaced by the address of symbol      }
+      { so op_csymbol(A_PUSH,S_L,strnew('P')); generates }
+      { an instruction which pushes the address of P     }
+      { to the stack                                     }
+      constructor op_csymbol(op : tasmop;_size : topsize;_op1 : pcsymbol);
+      constructor op_csymbol_reg(op : tasmop;_size : topsize;_op1 : pcsymbol;_op2 : tregister);
+      constructor op_csymbol_ref(op : tasmop;_size : topsize;_op1 : pcsymbol;_op2 : preference);
+      constructor op_csymbol_loc(op : tasmop;_size : topsize;_op1 : pcsymbol;_op2 : tlocation);
+
+     constructor op_ref_reglist(op: tasmop; _size : topsize; _op1: preference;_op2: tregisterlist);
+     constructor op_reglist_ref(op: tasmop; _size : topsize; _op1: tregisterlist; _op2: preference);
+
+      destructor done;virtual;
+       end;
+
+const
+       ait_bestreal = ait_real_64bit;
+type
+       pai_bestreal = pai_double;
+       tai_bestreal = tai_double;
+
+    const
+       maxvarregs = 5;
+
+       varregs : array[1..maxvarregs] of tregister =
+     (R_D2,R_D3,R_D4,R_D5,R_D7);
+
+       nextlabelnr : longint = 1;
+
+
+    { resets all values of ref to defaults }
+    procedure reset_reference(var ref : treference);
+
+    { same as reset_reference, but symbol is disposed }
+    { use this only for already used references       }
+    procedure clear_reference(var ref : treference);
+
+    { make l as a new label }
+    procedure getlabel(var l : plabel);
+    { frees the label if unused }
+    procedure freelabel(var l : plabel);
+    { make a new zero label }
+    procedure getzerolabel(var l : plabel);
+    { reset a label to a zero label }
+    procedure setzerolabel(var l : plabel);
+    {just get a label number }
+    procedure getlabelnr(var l : longint);
+
+    function newreference(const r : treference) : preference;
+
+    function reg2str(r : tregister) : string;
+
+    { generates an help record for constants }
+    function newcsymbol(const s : string;l : longint) : pcsymbol;
+
+    function lab2str(l : plabel) : string;
+
+    const
+       ao_unknown = $0;
+       { 8 bit reg }
+       ao_reg8 = $1;
+       { 16 bit reg }
+       ao_reg16 = $2;
+       { 32 bit reg }
+       ao_reg32 = $4;
+       ao_reg = (ao_reg8 or ao_reg16 or ao_reg32);
+
+
+       { for  push/pop operands }
+       ao_wordreg = (ao_reg16 or ao_reg32);
+       ao_imm8 = $8;            { 8 bit immediate }
+       ao_imm8S   = $10;                { 8 bit immediate sign extended }
+       ao_imm16   = $20;                { 16 bit immediate }
+       ao_imm32   = $40;                { 32 bit immediate }
+       ao_imm1    = $80;        { 1 bit immediate }
+
+       { for  unknown expressions }
+       ao_immunknown = ao_imm32;
+
+       { gen'l immediate }
+       ao_imm = (ao_imm8 or ao_imm8S or ao_imm16 or ao_imm32);
+       ao_disp8   = $200;               { 8 bit displacement (for  jumps) }
+       ao_disp16  = $400;               { 16 bit displacement }
+       ao_disp32  = $800;               { 32 bit displacement }
+
+       { general displacement }
+       ao_disp    = (ao_disp8 or ao_disp16 or ao_disp32);
+
+       { for  unknown size displacements }
+       ao_dispunknown = ao_disp32;
+       ao_mem8    = $1000;
+       ao_mem16   = $2000;
+       ao_mem32   = $4000;
+       ao_baseindex = $8000;
+
+       { general mem }
+       ao_mem     = (ao_disp or ao_mem8 or ao_mem16 or ao_mem32 or ao_baseindex);
+       ao_wordmem = (ao_mem16 or ao_mem32 or ao_disp or ao_baseindex);
+       ao_bytemem = (ao_mem8 or ao_disp or ao_baseindex);
+
+       ao_control = $40000;     { Control register }
+       ao_debug   = $80000;     { Debug register }
+       ao_test    = $100000;    { Test register }
+       ao_floatreg = $200000;   { Float register }
+
+
+       ao_jumpabsolute = $4000000;
+       ao_abs8 = $08000000;
+       ao_abs16 = $10000000;
+       ao_abs32 = $20000000;
+       ao_abs = (ao_abs8 or ao_abs16 or ao_abs32);
+
+       ao_none = $ff;
+
+  const
+     AB_DN     =  1;
+     AB_AN     =  2;
+     AB_INDAN  =  3;
+     AB_INDPP  =  4;
+     AB_MMIND  =  5;
+     AB_OFFAN  =  6;
+     AB_OFFIDX =  7;
+     AB_ABSW   =  8;
+     AB_ABSL   =  9;
+     AB_OFFPC  =  10;
+     AB_OFFIDXPC =11;
+     AB_IMM      =12;
+     AB_REGS     =13;       {*  movem       *}
+     AB_BBRANCH  =14;
+     AB_WBRANCH  =15;
+     AB_CCR      =16;
+     AB_SR       =17;
+     AB_USP      =18;
+     AB_MULDREGS =19;
+     AB_MULDREGU =20;
+
+     AF_DN      =(1 SHL AB_DN);
+     AF_AN      =(1 SHL AB_AN);
+     AF_INDAN   = (1 SHL AB_INDAN);
+     AF_INDPP   = (1 SHL AB_INDPP);
+     AF_MMIND   = (1 SHL AB_MMIND);
+     AF_OFFAN   = (1 SHL AB_OFFAN);
+     AF_OFFIDX  = (1 SHL AB_OFFIDX);
+     AF_ABSW    = (1 SHL AB_ABSW);
+     AF_ABSL    = (1 SHL AB_ABSL);
+     AF_OFFPC   = (1 SHL AB_OFFPC);
+     AF_OFFIDXPC= (1 SHL AB_OFFIDXPC);
+     AF_IMM      =(1 SHL AB_IMM);
+     AF_REGS    = (1 SHL AB_REGS);
+     AF_BBRANCH = (1 SHL AB_BBRANCH);
+     AF_WBRANCH = (1 SHL AB_WBRANCH);
+     AF_CCR     =(1 SHL AB_CCR);
+     AF_SR      =(1 SHL AB_SR);
+     AF_USP     =(1 SHL AB_USP);
+     AF_MULDREGS= (1 SHL AB_MULDREGS);
+     AF_MULDREGU= (1 SHL AB_MULDREGU);
+
+      AF_ALL     = AF_DN OR AF_AN OR AF_INDAN OR AF_INDPP OR AF_MMIND OR AF_OFFAN OR AF_OFFIDX OR AF_ABSW OR
+                  AF_ABSL OR AF_OFFPC OR AF_OFFIDXPC OR AF_IMM;
+      AF_ALLNA  = AF_DN OR AF_INDAN OR AF_INDPP OR AF_MMIND OR AF_OFFAN OR AF_OFFIDX OR AF_ABSW OR AF_ABSL
+                  OR AF_OFFPC OR AF_OFFIDXPC OR AF_IMM;
+
+      AF_ALT      = AF_DN OR AF_AN OR AF_INDAN OR AF_INDPP OR AF_MMIND OR AF_OFFAN OR
+                   AF_OFFIDX OR AF_ABSW OR AF_ABSL;
+
+      AF_ALTNA    = AF_DN OR AF_INDAN OR AF_INDPP OR AF_MMIND OR AF_OFFAN OR AF_OFFIDX OR AF_ABSW OR AF_ABSL;
+      AF_ALTM     = AF_INDAN OR AF_INDPP OR AF_MMIND OR AF_OFFAN OR AF_OFFIDX OR AF_ABSW OR AF_ABSL;
+      AF_CTL       = AF_INDAN OR AF_OFFAN OR AF_OFFIDX OR AF_ABSW OR AF_ABSL OR AF_OFFPC OR AF_OFFIDXPC;
+      AF_CTLNPC   = AF_INDAN OR AF_OFFAN OR AF_OFFIDX OR AF_ABSW OR AF_ABSL OR AF_OFFIDXPC;
+
+
+{ S_WL  (S_W|S_L)
+ S_BW   (S_B|S_W)}
+     const
+       S_ALL = [S_B] + [S_W] + [S_L];
+{#define S_ALL  (S_B|S_W|S_L)}
+
+
+    type
+     ttemplate = record
+        i : tasmop;
+        oc : longint;
+        ops : byte;
+       size: set of topsize;
+        o1,o2: longint;
+    end;
+
+       tins_cache = array[A_ABCD..A_UNLK] of longint;
+
+    var
+       ins_cache : tins_cache;
+       exprasmlist : paasmoutput;
+
+    const
+       it : array[0..188] of ttemplate = (
+
+    (   i:A_ABCD; oc: $C100; ops:2;size: [S_B];  o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_ABCD; oc: $C108; ops:2;size: [S_B];  o1:AF_MMIND;   o2:AF_MMIND        ),
+    (   i:A_ADD;  oc: $D000; ops:2;size: S_ALL;  o1:AF_ALL;     o2:AF_DN           ),
+    (   i:A_ADD;  oc: $D100; ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_ALTM         ),
+    (   i:A_ADD;  oc: $D0C0; ops:2;size: [S_W];  o1:AF_ALL;     o2:AF_AN           ),
+    (   i:A_ADD;  oc: $D1C0; ops:2;size: [S_L];  o1:AF_ALL;     o2:AF_AN           ),
+    (   i:A_ADD;  oc: $0600; ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_ALTNA        ),
+    (   i:A_ADDQ; oc: $5000; ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_ALT        ),
+    (   i:A_ADDX; oc: $D100; ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_ADDX; oc: $D108; ops:2;size: S_ALL;  o1:AF_MMIND;   o2:AF_MMIND        ),
+    (   i:A_AND;  oc: $C000; ops:2;size: S_ALL;  o1:AF_ALLNA;   o2:AF_DN           ),
+    (   i:A_AND;  oc: $C100; ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_ALTM         ),
+    (   i:A_AND;  oc: $0200; ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_ALTNA        ),
+    (   i:A_AND;  oc: $023C; ops:2;size: [S_B];  o1:AF_IMM;     o2:AF_CCR          ),
+    (   i:A_AND;  oc: $027C; ops:2;size: [S_W];  o1:AF_IMM;     o2:AF_SR           ),
+    (   i:A_ASL;  oc: $E120; ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_ASL;  oc: $E100; ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_DN         ),
+    (   i:A_ASL;  oc: $E1C0; ops:1;size: [S_W];  o1:0;          o2:AF_ALTM         ),
+    (   i:A_ASR;  oc: $E020; ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_ASR;  oc: $E000; ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_DN           ),
+    (   i:A_ASR;  oc: $E0C0; ops:1;size: [S_W];  o1:0;          o2:AF_ALTM         ),
+
+    (   i:A_BCC;  oc: $6400; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0               ),
+    (   i:A_BCS;  oc: $6500; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0             ),
+    (   i:A_BEQ;  oc: $6700; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0             ),
+    (   i:A_BGE;  oc: $6C00; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0             ),
+    (   i:A_BGT;  oc: $6E00; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0             ),
+    (   i:A_BHI;  oc: $6200; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0             ),
+    (   i:A_BLE;  oc: $6F00; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0               ),
+    (   i:A_BLS;  oc: $6300; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0               ),
+    (   i:A_BLT;  oc: $6D00; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0               ),
+    (   i:A_BMI;  oc: $6B00; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0             ),
+    (   i:A_BNE;  oc: $6600; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0             ),
+    (   i:A_BPL;  oc: $6A00; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0             ),
+    (   i:A_BVC;  oc: $6800; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0             ),
+    (   i:A_BVS;  oc: $6900; ops:1;size: [S_NO]; o1:AF_WBRANCH; o2:0             ),
+
+    {*      opcode   Temp   Rs  EAs Rd  EAd Siz Sizes  SModes   DModes    Spec# *}
+
+    (   i:A_BCHG; oc: $0140;  ops:2;size: [S_B];    o1:AF_DN;      o2:AF_ALTM         ),
+    (   i:A_BCHG; oc: $0140;  ops:2;size: [S_L];    o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_BCHG; oc: $0840;  ops:2;size: [S_B];    o1:AF_IMM;     o2:AF_ALTM         ),
+    (   i:A_BCHG; oc: $0840;  ops:2;size: [S_L];    o1:AF_IMM;     o2:AF_DN           ),
+    (   i:A_BCLR; oc: $0180;  ops:2;size: [S_B];    o1:AF_DN;      o2:AF_ALTM         ),
+    (   i:A_BCLR; oc: $0180;  ops:2;size: [S_L];    o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_BCLR; oc: $0880;  ops:2;size: [S_B];    o1:AF_IMM;     o2:AF_ALTM         ),
+    (   i:A_BCLR; oc: $0880;  ops:2;size: [S_L];    o1:AF_IMM;     o2:AF_DN           ),
+
+    (   i:A_BRA;  oc: $6000;  ops:1;size: [S_NO];    o1:AF_WBRANCH;o2:0              ),
+
+    (   i:A_BSET; oc: $01C0;  ops:2;size: [S_B];    o1:AF_DN;      o2:AF_ALTM         ),
+    (   i:A_BSET; oc: $01C0;  ops:2;size: [S_L];    o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_BSET; oc: $08C0;  ops:2;size: [S_B];    o1:AF_IMM;     o2:AF_ALTM         ),
+    (   i:A_BSET; oc: $08C0;  ops:2;size: [S_L];    o1:AF_IMM;     o2:AF_DN           ),
+    (   i:A_BTST; oc: $0100;  ops:2;size: [S_B];    o1:AF_DN;      o2:AF_ALTM         ),
+    (   i:A_BTST; oc: $0100;  ops:2;size: [S_L];    o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_BTST; oc: $0800;  ops:2;size: [S_B];    o1:AF_IMM;     o2:AF_ALTM         ),
+    (   i:A_BTST; oc: $0800;  ops:2;size: [S_L];    o1:AF_IMM;     o2:AF_DN           ),
+
+    {*      opcode   Temp   Rs  EAs Rd  EAd Siz Sizes  SModes   DModes    Spec# *}
+
+    (   i:A_CHK;  oc: $4180;  ops:2;size: [S_W];  o1:AF_ALLNA;   o2:AF_DN           ),
+    (   i:A_CLR;  oc: $4200;  ops:1;size: S_ALL;  o1:AF_ALTNA;   o2:0  ),
+    (   i:A_CMP;  oc: $B000;  ops:2;size: S_ALL;  o1:AF_ALLNA;   o2:AF_DN           ),
+    (   i:A_CMP;  oc: $B000;  ops:2;size: [S_WL]; o1:AF_AN;      o2:AF_DN           ),
+    (   i:A_CMP;  oc: $B0C0;  ops:2;size: [S_W];  o1:AF_ALL;     o2:AF_AN           ),
+    (   i:A_CMP;  oc: $B1C0;  ops:2;size: [S_L];  o1:AF_ALL;     o2:AF_AN           ),
+    ( i:A_CMP;  oc: $0C00;  ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_ALTNA        ),
+    (   i:A_CMP;  oc: $B108;  ops:2;size: S_ALL;  o1:AF_INDPP;   o2:AF_INDPP        ),
+
+    ( i:A_DBCC; oc: $54C8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBCS; oc: $55C8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBEQ; oc: $57C8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBF; oc: $51C8;   ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBGE; oc: $5CC8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBGT; oc: $5EC8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBHI; oc: $52C8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBLE; oc: $5FC8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBLS; oc: $53C8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBLT; oc: $5DC8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBMI; oc: $5BC8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBNE; oc: $56C8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBPL; oc: $5AC8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBT; oc: $50C8;   ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBVC; oc: $58C8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+    (   i:A_DBVS; oc: $59C8;  ops:2;size: [S_NO];    o1:AF_DN;   o2:AF_WBRANCH       ),
+
+    {*      opcode   Temp   Rs  EAs Rd  EAd Siz Sizes  SModes   DModes    Spec# *}
+
+    (   i:A_DIVS; oc: $81C0;  ops:2;size: [S_W];    o1:AF_ALLNA;   o2:AF_DN           ),
+    (   i:A_DIVS; oc: $4C40;  ops:2;size: [S_L];    o1:AF_ALLNA;   o2:AF_DN OR AF_MULDREGS),  {*  020 *}
+    (   i:A_DIVU; oc: $80C0;  ops:2;size: [S_W];    o1:AF_ALLNA;   o2:AF_DN           ),
+    (   i:A_DIVU; oc: $4C40;  ops:2;size: [S_L];    o1:AF_ALLNA;   o2:AF_DN OR AF_MULDREGU),  {*  020 *}
+
+
+    (   i:A_EOR;   oc: $B100; ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_ALTNA        ),
+    (   i:A_EOR;  oc: $0A00;  ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_ALTNA        ),
+    (   i:A_EOR;  oc: $0A3C;  ops:2;size: [S_B];  o1:AF_IMM;     o2:AF_CCR          ),
+    (   i:A_EOR;  oc: $0A7C;  ops:2;size: [S_W];  o1:AF_IMM;     o2:AF_SR           ),
+    (   i:A_EXG;  oc: $C140;  ops:2;size: [S_L];  o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_EXG;  oc: $C148;  ops:2;size: [S_L];  o1:AF_AN;      o2:AF_AN           ),
+    (   i:A_EXG;  oc: $C188;  ops:2;size: [S_L];  o1:AF_DN;      o2:AF_AN           ),
+    (   i:A_EXG;  oc: $C188;  ops:2;size: [S_L];  o1:AF_AN;      o2:AF_DN           ),
+    (   i:A_EXT;  oc: $4880;  ops:1;size: [S_W];  o1:AF_DN;      o2:0    ),
+    (   i:A_EXT;  oc: $48C0;  ops:1;size: [S_L];  o1:AF_DN;      o2:0    ),
+    { MC68020 }
+    (   i:A_EXTB; oc: $49C0;  ops:1;size: [S_L];  o1:AF_DN;      o2:0    ),
+    (   i:A_ILLEGAL;oc: $4AFC;ops:0;size: [S_NO];   o1:0;             o2:0    ),
+
+
+    {*
+     *  note: BSR/BSR/JSR ordering must remain as it is (passc.c optimizations)
+     *}
+    (   i:A_JMP;  oc: $4EC0;  ops:1;size: [S_NO];      o1:AF_CTL;     o2:0               ),
+    (   i:A_BSR;  oc: $6100;  ops:1;size: [S_NO];      o1:AF_WBRANCH; o2: 0              ),
+    (   i:A_JSR;  oc: $4E80;  ops:1;size: [S_NO];      o1:AF_CTL;     o2:0               ),
+
+    (   i:A_LEA;  oc: $41C0;  ops:2;size: [S_L];    o1:AF_CTL;     o2:AF_AN           ),
+    (   i:A_LINK; oc: $4E50;  ops:2;size: [S_W];    o1:AF_AN;      o2:AF_IMM          ),
+
+    {*      opcode   Temp   Rs  EAs Rd  EAd Siz Sizes  SModes   DModes    Spec# *}
+
+    (   i:A_LSL;  oc: $E128;  ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_LSL;  oc: $E108;  ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_DN           ),
+    (   i:A_LSL;  oc: $E3C0;  ops:1;size: [S_W];  o1:0;          o2:AF_ALTM         ),
+    (   i:A_LSR;  oc: $E028;  ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_LSR;  oc: $E008;  ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_DN           ),
+    (   i:A_LSR;  oc: $E2C0;  ops:1;size: [S_W];  o1:0;          o2:AF_ALTM         ),
+
+    (   i:A_MOVE; oc: $2000;  ops:2;size: [S_L];    o1:AF_ALLNA;   o2:AF_ALTNA        ),
+    (   i:A_MOVE; oc: $3000;  ops:2;size: [S_W];    o1:AF_ALLNA;   o2:AF_ALTNA        ),
+    (   i:A_MOVE; oc: $1000;  ops:2;size: [S_B];    o1:AF_ALLNA;   o2:AF_ALTNA        ),
+    (   i:A_MOVE; oc: $2000;  ops:2;size: [S_L];    o1:AF_AN;      o2:AF_ALTNA        ),
+    (   i:A_MOVE; oc: $3000;  ops:2;size: [S_W];    o1:AF_AN;      o2:AF_ALTNA        ),
+
+  {* 68010
+   *(   'MOVE'; i:A_MOVE; oc: $42C0; -1; -1;  0;  3; -1; size: [S_W];    o1:AF_CCR;     o1:AF_ALTNA        ),
+   *}
+
+    (   i:A_MOVE; oc: $44C0;  ops:2;size: [S_W];    o1:AF_ALLNA;   o2:AF_CCR          ),
+    (   i:A_MOVE; oc: $46C0;  ops:2;size: [S_W];    o1:AF_ALLNA;   o2:AF_SR           ),
+    (   i:A_MOVE; oc: $40C0;  ops:2;size: [S_W];    o1:AF_SR;      o2:AF_ALTNA        ),
+    (   i:A_MOVE; oc: $3040;  ops:2;size: [S_W];    o1:AF_ALL;     o2:AF_AN           ),
+    (   i:A_MOVE; oc: $2040;  ops:2;size: [S_L];    o1:AF_ALL;     o2:AF_AN           ),
+    (   i:A_MOVE; oc: $4E68;  ops:2;size: [S_L];    o1:AF_USP;     o2:AF_AN           ),
+    (   i:A_MOVE; oc: $4E60;  ops:2;size: [S_L];    o1:AF_AN;      o2:AF_USP          ),
+    {* MOVEC 68010  *}
+    (   i:A_MOVEM;oc: $48C0; ops:8;size: [S_L];    o1:AF_REGS;    o2:AF_CTL OR AF_MMIND ),
+    (   i:A_MOVEM;oc: $4880; ops:8;size: [S_W];    o1:AF_REGS;    o2:AF_CTL OR AF_MMIND ),
+    (   i:A_MOVEM;oc: $4CC0; ops:8;size: [S_L];    o1:AF_CTL OR AF_INDPP;    o2:AF_REGS ),
+    (   i:A_MOVEM;oc: $4C80; ops:8;size: [S_W];    o1:AF_CTL OR AF_INDPP;    o2:AF_REGS ),
+    (   i:A_MOVEP;oc: $0188; ops:2;size: [S_W];    o1:AF_DN;      o2:AF_OFFAN        ),
+    (   i:A_MOVEP;oc: $01C8; ops:2;size: [S_L];    o1:AF_DN;      o2:AF_OFFAN        ),
+    (   i:A_MOVEP;oc: $0108; ops:2;size: [S_W];    o1:AF_OFFAN;   o2:AF_DN           ),
+    (   i:A_MOVEP;oc: $0148; ops:2;size: [S_L];    o1:AF_OFFAN;   o2:AF_DN           ),
+    {*  MOVES   68010   *}
+    (   i:A_MOVEQ;oc: $7000; ops:2;size: [S_L];    o1:AF_IMM;    o2:AF_DN           ),
+
+    {*      opcode   Temp   Rs  EAs Rd  EAd Siz Sizes  SModes   DModes    Spec# *}
+
+    (   i:A_MULS; oc: $C1C0;  ops:2;size: [S_W];    o1:AF_ALLNA;   o2:AF_DN           ),
+    (   i:A_MULS; oc: $4C00;  ops:2;size: [S_L];    o1:AF_ALLNA;   o2:AF_DN OR AF_MULDREGS),  {*  020 *}
+    (   i:A_MULU; oc: $C0C0;  ops:2;size: [S_W];    o1:AF_ALLNA;   o2:AF_DN           ),
+    (   i:A_MULU; oc: $4C00;  ops:2;size: [S_L];    o1:AF_ALLNA;   o2:AF_DN OR AF_MULDREGU),  {*  020 *}
+    (   i:A_NBCD; oc: $4800;  ops:1;size: [S_B];    o1:AF_ALTNA;   o2:0    ),
+    (   i:A_NEG;  oc: $4400;  ops:1;size: S_ALL;    o1:AF_ALTNA;   o2:0    ),
+    (   i:A_NEGX; oc: $4000;  ops:1;size: S_ALL;    o1:AF_ALTNA;   o2:0    ),
+    (   i:A_NOP;  oc: $4E71;  ops:0;size: [S_NO];   o1:0;          o2:0    ),
+    (   i:A_NOT;  oc: $4600;  ops:1;size: S_ALL;    o1:AF_ALTNA;   o2:0    ),
+
+    (   i:A_OR;   oc: $8000;  ops:2;size: S_ALL;    o1:AF_ALLNA;   o2:AF_DN           ),
+    (   i:A_OR;   oc: $8100;  ops:2;size: S_ALL;    o1:AF_DN;      o2:AF_ALTNA        ),
+    ( i:A_OR;   oc: $0000;  ops:2;size: S_ALL;    o1:AF_IMM;     o2:AF_ALTNA        ),
+    (   i:A_OR;   oc: $003C;  ops:2;size: [S_B];    o1:AF_IMM;     o2:AF_CCR          ),
+    (   i:A_OR;   oc: $007C;  ops:2;size: [S_W];    o1:AF_IMM;     o2:AF_SR           ),
+    (   i:A_PEA;  oc: $4840;  ops:1;size: [S_L];    o1:AF_CTL;     o2:0               ),
+    (   i:A_RESET;oc: $4E70;  ops:0;size: [S_NO];   o1:0;          o2:0               ),
+
+    {*      opcode   Temp   Rs  EAs Rd  EAd Siz Sizes  SModes   DModes    Spec# *}
+
+    (   i:A_ROL;  oc: $E138;  ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_ROL;  oc: $E118;  ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_DN           ),
+    (   i:A_ROL;  oc: $E7C0;  ops:1;size: [S_W];  o1:AF_ALTM;    o2:0               ),
+    (   i:A_ROR;  oc: $E038;  ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_ROR;  oc: $E018;  ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_DN           ),
+    (   i:A_ROR;  oc: $E6C0;  ops:1;size: [S_W];  o1:AF_ALTM;    o2:0               ),
+
+    (   i:A_ROXL; oc: $E130;  ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_ROXL; oc: $E110;  ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_DN           ),
+    (   i:A_ROXL; oc: $E5C0;  ops:1;size: [S_W];  o1:AF_ALTM;    o2:0               ),
+    (   i:A_ROXR; oc: $E030;  ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_ROXR; oc: $E010;  ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_DN           ),
+    (   i:A_ROXR; oc: $E4C0;  ops:1;size: [S_W];  o1:AF_ALTM;    o2:0               ),
+
+    {*  RTD 68010   *}
+    (   i:A_RTE;  oc: $4E73;  ops:0;size: [S_NO];   o1:0;          o2:0               ),
+    (   i:A_RTR;  oc: $4E77;  ops:0;size: [S_NO];   o1:0;          o2:0               ),
+    (   i:A_RTS;  oc: $4E75;  ops:0;size: [S_NO];   o1:0;          o2:0               ),
+    (   i:A_SBCD; oc: $8100;  ops:2;size: [S_B];    o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_SBCD; oc: $8108;  ops:2;size: [S_B];    o1:AF_MMIND;   o2:AF_MMIND        ),
+
+    {*      opcode   Temp   Rs  EAs Rd  EAd Siz Sizes  SModes   DModes    Spec# *}
+
+    {* SCC note; even though they are in the same group since all have the
+     * same note if one isn't accepted none of the others will be either
+     *}
+
+    (   i:A_SCC;  oc: $54C0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SCS;  oc: $55C0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SEQ;  oc: $57C0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SF;   oc: $51C0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SGE;  oc: $5CC0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SGT;  oc: $5EC0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SHI;  oc: $52C0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SLE;  oc: $5FC0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SLS;  oc: $53C0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SLT;  oc: $5DC0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SMI;  oc: $5BC0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SNE;  oc: $56C0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SPL;  oc: $5AC0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_ST;   oc: $50C0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SVC;  oc: $58C0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+    (   i:A_SVS;  oc: $59C0;  ops:1;size: [S_B]; o1:AF_ALTNA; o2: 0        ),
+
+    {*      opcode   Temp   Rs  EAs Rd  EAd Siz Sizes  SModes   DModes    Spec# *}
+
+    (   i:A_STOP; oc: $4E72; ops:0; size: [S_W]; o1:AF_IMM;  o2:   0               ),
+
+    (   i:A_SUB;  oc: $9000; ops:2;size: S_ALL;  o1:AF_ALL;     o2:AF_DN           ),
+    (   i:A_SUB;  oc: $9100; ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_ALTM         ),
+    (   i:A_SUB;  oc: $90C0; ops:2;size: [S_W];  o1:AF_ALL;     o2:AF_AN           ),
+    (   i:A_SUB;  oc: $91C0; ops:2;size: [S_L];  o1:AF_ALL;     o2:AF_AN           ),
+    (   i:A_SUB;  oc: $0400; ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_ALTNA        ),
+    (   i:A_SUBQ; oc: $5100; ops:2;size: S_ALL;  o1:AF_IMM;     o2:AF_ALT          ),
+    (   i:A_SUBX; oc: $9100; ops:2;size: S_ALL;  o1:AF_DN;      o2:AF_DN           ),
+    (   i:A_SUBX; oc: $9108; ops:2;size: S_ALL;  o1:AF_MMIND;   o2:AF_MMIND        ),
+
+    (   i:A_SWAP; oc: $4840; ops:1;size: [S_W];  o1:AF_DN;      o2:0    ),
+    (   i:A_TAS;  oc: $4AC0; ops:1;size: [S_B];  o1:AF_ALTNA;   o2:0    ),
+    (   i:A_TRAP; oc: $4E40; ops:1;size: [S_NO]; o1:AF_IMM;     o2:0               ),
+    (   i:A_TRAPV;oc: $4E76; ops:0;size: [S_NO]; o1:0;          o2:0               ),
+    (   i:A_TST;  oc: $4A00; ops:1;size: S_ALL;  o1:AF_ALTNA;   o2:0               ),
+    (   i:A_UNLK; oc: $4E58; ops:1;size: [S_NO]; o1:AF_AN;      o2:0               ),
+    ( i:A_NONE)
+    );
+
+{****************************************************************************
+                            Assembler Mnemoics
+****************************************************************************}
+
+   const
+     firstop = A_ABCD;
+     lastop = A_LABEL;
+
+     mot_op2str : array[firstop..lastop] of string[10] =
+       { 68000 only instructions }
+       ('abcd','add', 'adda','addi','addq','addx','and','andi',
+       'asl','asr','bcc','bcs','beq','bge','bgt','bhi',
+       'ble','bls','blt','bmi','bne','bpl','bvc','bvs',
+       'bchg','bclr','bra','bset','bsr','btst','chk',
+       'clr','cmp','cmpa','cmpi','cmpm','dbcc','dbcs','dbeq','dbge',
+       'dbgt','dbhi','dble','dbls','dblt','dbmi','dbne','dbra',
+       'dbpl','dbt','dbvc','dbvs','dbf','divs','divu',
+       'eor','eori','exg','illegal','ext','jmp','jsr',
+       'lea','link','lsl','lsr','move','movea','movei','moveq',
+       'movem','movep','muls','mulu','nbcd','neg','negx',
+       'nop','not','or','ori','pea','rol','ror','roxl',
+       'roxr','rtr','rts','sbcd','scc','scs','seq','sge',
+       'sgt','shi','sle','sls','slt','smi','sne',
+       'spl','st','svc','svs','sf','sub','suba','subi','subq',
+       'subx','swap','tas','trap','trapv','tst','unlk',
+       'rte','reset','stop',
+       { MC68010 instructions }
+       'bkpt','movec','moves','rtd',
+       { MC68020 instructions }
+       'bfchg','bfclr','bfexts','bfextu','bfffo',
+       'bfins','bfset','bftst','callm','cas','cas2',
+       'chk2','cmp2','divsl','divul','extb','pack','rtm',
+       'trapcc','tracs','trapeq','trapf','trapge','trapgt',
+       'traphi','traple','trapls','traplt','trapmi','trapne',
+       'trappl','trapt','trapvc','trapvs','unpk',
+       { FPU Processor instructions - directly supported only. }
+       { IEEE aware and misc. condition codes not supported   }
+       'fabs','fadd',
+       'fbeq','fbne','fbngt','fbgt','fbge','fbnge',
+       'fblt','fbnlt','fble','fbgl','fbngl','fbgle','fbngle',
+       'fdbeq','fdbne','fdbgt','fdbngt','fdbge','fdnbge',
+       'fdblt','fdbnlt','fdble','fdbgl','fdbngl','fdbgle','fbdngle',
+       'fseq','fsne','fsgt','fsngt','fsge','fsnge',
+       'fslt','fsnlt','fsle','fsgl','fsngl','fsgle','fsngle',
+       'fcmp','fdiv','fmove','fmovem',
+       'fmul','fneg','fnop','fsqrt','fsub','fsgldiv',
+       'fsflmul','ftst',
+       'ftrapeq','ftrapne','ftrapgt','ftrapngt','ftrapge','ftrapnge',
+       'ftraplt','ftrapnlt','ftraple','ftrapgl','ftrapngl','ftrapgle',
+       'ftrapngle',
+       { Useful for assembly langage output }
+       { Protected instructions }
+       'cprestore','cpsave',
+       { FPU Unit protected instructions                    }
+       { and 68030/68851 common MMU instructions            }
+       { (this may include 68040 MMU instructions)          }
+       'frestore','fsave','pflush','pflusha','pload','pmove','ptest',
+       { Useful for assembly langage output }
+       '');
+
+     mot_opsize2str : array[topsize] of string[2] =
+      ('','.b','.w','.l','.b','.b','.w','.d','.s','.x');
+
+     mot_reg2str : array[R_NO..R_FPSR] of string[6] =
+      ('', 'd0','d1','d2','d3','d4','d5','d6','d7',
+       'a0','a1','a2','a3','a4','a5','a6','sp',
+       '-(sp)','(sp)+',
+       'ccr','fp0','fp1','fp2','fp3','fp4','fp5',
+       'fp6','fp7','fpcr','sr','ssp','dfc',
+       'sfc','vbr','fpsr');
+
+     gas_opsize2str : array[topsize] of string[2] =
+      ('','.b','.w','.l','.b','.b','.w','.d','.s','.x');
+
+     gas_reg2str : array[R_NO..R_FPSR] of string[6] =
+      ('', 'd0','d1','d2','d3','d4','d5','d6','d7',
+       'a0','a1','a2','a3','a4','a5','a6','sp',
+       '-(sp)','(sp)+',
+       'ccr','fp0','fp1','fp2','fp3','fp4','fp5',
+       'fp6','fp7','fpcr','sr','ssp','dfc',
+       'sfc','vbr','fpsr');
+
+     mit_opsize2str : array[topsize] of string[2] =
+      ('','b','w','l','b','b','w','d','s','x');
+
+     mit_reg2str : array[R_NO..R_FPSR] of string[6] =
+      ('', 'd0','d1','d2','d3','d4','d5','d6','d7',
+       'a0','a1','a2','a3','a4','a5','a6','sp',
+       'sp@-','sp@+',
+       'ccr','fp0','fp1','fp2','fp3','fp4','fp5',
+       'fp6','fp7','fpcr','sr','ssp','dfc',
+       'sfc','vbr','fpsr');
+
+
+  implementation
+
+    function reg2str(r : tregister) : string;
+
+      const
+     a : array[R_NO..R_FPSR] of string[3] =
+      ('','D0','D1','D2','D3','D4','D5','D6','D7',
+       'A0','A1','A2','A3','A4','A5','A6','A7',
+      '-(SP)','(SP)+',
+       'CCR','FP0','FP1','FP2',
+       'FP3','FP4','FP5','FP6','FP7','FPCR','SR',
+       'SSP','DFC','SFC','VBR','FPSR');
+
+      begin
+     reg2str:=a[r];
+      end;
+
+    function newreference(const r : treference) : preference;
+
+      var
+     p : preference;
+
+      begin
+     new(p);
+     p^:=r;
+     if assigned(r.symbol) then
+       p^.symbol:=stringdup(r.symbol^);
+     newreference:=p;
+      end;
+
+    function lab2str(l : plabel) : string;
+
+      begin
+         if (l=nil) or (l^.nb=0) then
+{$ifdef EXTDEBUG}
+           lab2str:='ILLEGAL'
+         else
+           lab2str:=target_info.labelprefix+tostr(l^.nb);
+{$else EXTDEBUG}
+           internalerror(2000);
+         lab2str:=target_info.labelprefix+tostr(l^.nb);
+{$endif EXTDEBUG}
+
+         l^.is_used:=true;
+      end;
+
+
+    procedure reset_reference(var ref : treference);
+
+      begin
+         with ref do
+        begin
+          index:=R_NO;
+          base:=R_NO;
+          segment:=R_DEFAULT_SEG;
+          offset:=0;
+          scalefactor:=1;
+          isintvalue:=false;
+          symbol:=nil;
+          direction := dir_none;
+        end;
+      end;
+
+    procedure clear_reference(var ref : treference);
+
+      begin
+     stringdispose(ref.symbol);
+     reset_reference(ref);
+      end;
+
+    procedure getlabel(var l : plabel);
+
+      begin
+     new(l);
+     l^.nb:=nextlabelnr;
+     l^.is_used:=false;
+     l^.is_set:=false;
+     l^.refcount:=0;
+     inc(nextlabelnr);
+      end;
+
+    procedure freelabel(var l : plabel);
+
+      begin
+     if (l<>nil) and (not l^.is_set) and (not l^.is_used) then
+       dispose(l);
+     l:=nil;
+      end;
+
+    procedure setzerolabel(var l : plabel);
+
+      begin
+     l^.nb:=0;
+     l^.is_used:=false;
+     l^.is_set:=false;
+     l^.refcount:=0;
+      end;
+
+    procedure getzerolabel(var l : plabel);
+
+      begin
+     new(l);
+     l^.nb:=0;
+     l^.is_used:=false;
+     l^.is_set:=false;
+     l^.refcount:=0;
+      end;
+
+    procedure getlabelnr(var l : longint);
+
+      begin
+     l:=nextlabelnr;
+     inc(nextlabelnr);
+      end;
+
+    function newcsymbol(const s : string;l : longint) : pcsymbol;
+
+      var
+     p : pcsymbol;
+
+      begin
+     new(p);
+     p^.symbol:=strpnew(s);
+     p^.offset:=l;
+     newcsymbol:=p;
+      end;
+
+    procedure disposecsymbol(p : pcsymbol);
+
+      begin
+      strdispose(p^.symbol);
+      dispose(p);
+      end;
+
+{****************************************************************************
+                 TAI68k
+ ****************************************************************************}
+
+    constructor tai68k.op_none(op : tasmop;_size : topsize);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_none;
+     op2t:=top_none;
+     op3t:=top_none;
+     size:=_size;
+
+     { the following isn't required ! }
+     op1:=nil;
+     op2:=nil;
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_reg(op : tasmop;_size : topsize;_op1 : tregister);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_reg;
+     op2t:=top_none;
+     op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+
+     op2:=nil;
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_const(op : tasmop;_size : topsize;_op1 : longint);
+
+ begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_const;
+     op2t:=top_none;
+     op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+
+     op2:=nil;
+     op3:=nil;
+  end;
+
+
+
+    constructor tai68k.op_ref(op : tasmop;_size : topsize;_op1 : preference);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op2t:=top_none;
+     op3t:=top_none;
+     size:=_size;
+     if _op1^.isintvalue then
+       begin
+          op1t:=top_const;
+          op1:=pointer(_op1^.offset);
+       end
+     else
+       begin
+          op1t:=top_ref;
+          op1:=pointer(_op1);
+       end;
+
+     op2:=nil;
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_loc(op : tasmop;_size : topsize;_op1 : tlocation);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op2t:=top_none;
+     op3t:=top_none;
+     size:=_size;
+     if (_op1.loc=loc_register) or (_op1.loc=loc_cregister)  then
+       begin
+         op1t:=top_reg;
+         op1:=pointer(_op1.register);
+       end
+     else
+     if _op1.reference.isintvalue then
+       begin
+          op1t:=top_const;
+          op1:=pointer(_op1.reference.offset);
+       end
+     else
+       begin
+          op1t:=top_ref;
+          op1:=pointer(newreference(_op1.reference));
+       end;
+
+     op2:=nil;
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_reg_reg(op : tasmop;_size : topsize;_op1,_op2 : tregister);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_reg;
+     op2t:=top_reg;
+     op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+     op2:=pointer(_op2);
+
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_reg_ref(op : tasmop;_size : topsize;_op1 : tregister;_op2 : preference);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_reg;
+     op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+
+     if _op2^.isintvalue then
+       begin
+          op2t:=top_const;
+          op2:=pointer(_op2^.offset);
+       end
+     else
+       begin
+          op2t:=top_ref;
+          op2:=pointer(_op2);
+       end;
+
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_reg_loc(op : tasmop;_size : topsize;_op1 : tregister;_op2 : tlocation);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_reg;
+     op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+
+     if (_op2.loc=loc_register) or (_op2.loc=loc_cregister)  then
+       begin
+         op2t:=top_reg;
+         op2:=pointer(_op2.register);
+       end
+     else
+     if _op2.reference.isintvalue then
+       begin
+          op2t:=top_const;
+          op2:=pointer(_op2.reference.offset);
+       end
+     else
+       begin
+          op2t:=top_ref;
+          op2:=pointer(newreference(_op2.reference));
+       end;
+
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_loc_reg(op : tasmop;_size : topsize;_op1 : tlocation;_op2 : tregister);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op2t:=top_reg;
+     op3t:=top_none;
+     size:=_size;
+     op2:=pointer(_op2);
+
+     if (_op1.loc=loc_register) or (_op1.loc=loc_cregister)  then
+       begin
+         op1t:=top_reg;
+         op1:=pointer(_op1.register);
+       end
+     else
+     if _op1.reference.isintvalue then
+       begin
+          op1t:=top_const;
+          op1:=pointer(_op1.reference.offset);
+       end
+     else
+       begin
+          op1t:=top_ref;
+          op1:=pointer(newreference(_op1.reference));
+       end;
+
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_const_reg_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister;_op3 : tregister);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_const;
+     op2t:=top_reg;
+     op3t:=top_reg;
+     size:=_size;
+     op1:=pointer(_op1);
+     op2:=pointer(_op2);
+     op3:=pointer(_op3);
+      end;
+
+  constructor tai68k.op_reg_const(op: tasmop; _size: topsize; _op1: tregister; _op2: longint);
+   begin
+    inherited init;
+    typ := ait_instruction;
+    _operator := op;
+    op1t := top_reg;
+    op2t := top_const;
+    op3t := top_none;
+    op1 := pointer(_op1);
+    op2 := pointer(_op2);
+    size := _size;
+   end;
+
+
+    constructor tai68k.op_reg_reg_reg(op : tasmop;_size : topsize;_op1 : tregister;_op2 : tregister;_op3 : tregister);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_reg;
+     op2t:=top_reg;
+     op3t:=top_reg;
+     size:=_size;
+     op1:=pointer(_op1);
+     op2:=pointer(_op2);
+     op3:=pointer(_op3);
+      end;
+
+    constructor tai68k.op_const_reg(op : tasmop;_size : topsize;_op1 : longint;_op2 : tregister);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_const;
+     op2t:=top_reg;
+     op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+     op2:=pointer(_op2);
+
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_const_const(op : tasmop;_size : topsize;_op1,_op2 : longint);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_const;
+     op2t:=top_const;
+     op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+     op2:=pointer(_op2);
+
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_const_ref(op : tasmop;_size : topsize;_op1 : longint;_op2 : preference);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_const;
+     op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+
+     if _op2^.isintvalue then
+       begin
+          op2t:=top_const;
+          op2:=pointer(_op2^.offset);
+       end
+     else
+       begin
+          op2t:=top_ref;
+          op2:=pointer(_op2);
+       end;
+
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_const_loc(op : tasmop;_size : topsize;_op1 : longint;_op2 : tlocation);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_const;
+     op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+
+     if (_op2.loc=loc_register) or (_op2.loc=loc_cregister)  then
+       begin
+         op2t:=top_reg;
+         op2:=pointer(_op2.register);
+       end
+     else
+     if _op2.reference.isintvalue then
+       begin
+          op2t:=top_const;
+          op2:=pointer(_op2.reference.offset);
+       end
+     else
+       begin
+          op2t:=top_ref;
+          op2:=pointer(newreference(_op2.reference));
+       end;
+
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_ref_reg(op : tasmop;_size : topsize;_op1 : preference;_op2 : tregister);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op2t:=top_reg;
+     op3t:=top_none;
+     size:=_size;
+     op2:=pointer(_op2);
+
+     if _op1^.isintvalue then
+       begin
+          op1t:=top_const;
+          op1:=pointer(_op1^.offset);
+       end
+     else
+       begin
+          op1t:=top_ref;
+          op1:=pointer(_op1);
+       end;
+
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_ref_ref(op : tasmop;_size : topsize;_op1,_op2 : preference);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op3t:=top_none;
+     size:=_size;
+
+     if _op1^.isintvalue then
+       begin
+          op1t:=top_const;
+          op1:=pointer(_op1^.offset);
+       end
+     else
+       begin
+          op1t:=top_ref;
+          op1:=pointer(_op1);
+       end;
+
+     if _op2^.isintvalue then
+       begin
+          op2t:=top_const;
+          op2:=pointer(_op2^.offset);
+       end
+     else
+       begin
+          op2t:=top_ref;
+          op2:=pointer(_op2);
+       end;
+
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_csymbol(op : tasmop;_size : topsize;_op1 : pcsymbol);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     if (op=A_JSR) and
+        (use_esp_stackframe) then
+      Message(cg_e_stackframe_with_esp);
+     op1t:=top_symbol;
+     op2t:=top_none;
+     op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+
+     op2:=nil;
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_csymbol_reg(op : tasmop;_size : topsize;_op1 : pcsymbol;_op2 : tregister);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_symbol;
+     op2t:=top_reg;
+      op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+     op2:=pointer(_op2);
+
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_csymbol_ref(op : tasmop;_size : topsize;_op1 : pcsymbol;_op2 : preference);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_symbol;
+     op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+
+     if _op2^.isintvalue then
+       begin
+          op2t:=top_const;
+          op2:=pointer(_op2^.offset);
+       end
+     else
+       begin
+          op2t:=top_ref;
+          op2:=pointer(_op2);
+       end;
+
+     op3:=nil;
+      end;
+
+    constructor tai68k.op_csymbol_loc(op : tasmop;_size : topsize;_op1 : pcsymbol;_op2 : tlocation);
+
+      begin
+     inherited init;
+     typ:=ait_instruction;
+     _operator:=op;
+     op1t:=top_symbol;
+     op3t:=top_none;
+     size:=_size;
+     op1:=pointer(_op1);
+
+     if (_op2.loc=loc_register) or (_op2.loc=loc_cregister)  then
+       begin
+         op2t:=top_reg;
+         op2:=pointer(_op2.register);
+       end
+     else
+     if _op2.reference.isintvalue then
+       begin
+          op2t:=top_const;
+          op2:=pointer(_op2.reference.offset);
+       end
+     else
+       begin
+          op2t:=top_ref;
+          op2:=pointer(newreference(_op2.reference));
+       end;
+
+     op3:=nil;
+      end;
+
+   destructor tai68k.done;
+
+     begin
+    if op1t=top_symbol then
+      disposecsymbol(pcsymbol(op1))
+    else if op1t=top_ref then
+      begin
+         clear_reference(preference(op1)^);
+         dispose(preference(op1));
+      end;
+    if op2t=top_symbol then
+      disposecsymbol(pcsymbol(op2))
+    else if op2t=top_ref then
+      begin
+         clear_reference(preference(op2)^);
+         dispose(preference(op2));
+      end;
+    if op3t=top_symbol then
+      disposecsymbol(pcsymbol(op3))
+    else if op3t = top_ref then
+      begin
+         clear_reference(preference(op3)^);
+         dispose(preference(op3));
+      end;
+    inherited done;
+     end;
+
+
+   constructor tai68k.op_ref_reglist(op: tasmop; _size : topsize; _op1: preference;_op2: tregisterlist);
+   Begin
+     Inherited Init;
+      typ:=ait_instruction;
+      _operator:=op;
+      op2t:=top_reglist;
+      op3t:=top_none;
+      size:=_size;
+     reglist := _op2;
+
+      if _op1^.isintvalue then
+        begin
+           op1t:=top_const;
+           op1:=pointer(_op1^.offset);
+        end
+      else
+        begin
+           op1t:=top_ref;
+           op1:=pointer(_op1);
+        end;
+
+      op3:=nil;
+   end;
+
+
+   constructor tai68k.op_reglist_ref(op: tasmop; _size : topsize; _op1: tregisterlist; _op2: preference);
+   Begin
+     Inherited Init;
+      typ:=ait_instruction;
+
+      _operator:=op;
+      reglist:=_op1;
+
+     op1t:=top_reglist;
+      op3t:=top_none;
+      size:=_size;
+
+      if _op2^.isintvalue then
+        begin
+           op2t:=top_const;
+           op2:=pointer(_op2^.offset);
+        end
+      else
+        begin
+           op2t:=top_ref;
+           op2:=pointer(_op2);
+        end;
+      op3:=nil;
+   end;
+
+
+
+{****************************************************************************
+                              TAI_LABELED
+ ****************************************************************************}
+
+    constructor tai_labeled.init(op : tasmop; l : plabel);
+
+      begin
+         inherited init;
+         typ:=ait_labeled_instruction;
+         _operator:=op;
+         _op1:=R_NO;
+         lab:=l;
+         lab^.is_used:=true;
+         inc(lab^.refcount);
+      end;
+
+    constructor tai_labeled.init_reg(op : tasmop; l : plabel; reg: tregister);
+
+      begin
+         inherited init;
+         typ:=ait_labeled_instruction;
+         _op1:=reg;
+         _operator:=op;
+         lab:=l;
+         lab^.is_used:=true;
+         inc(lab^.refcount);
+      end;
+
+    destructor tai_labeled.done;
+
+      begin
+         dec(lab^.refcount);
+         if lab^.refcount=0 then
+           Begin
+             lab^.is_used := False;
+             If Not(lab^.is_set) Then
+               Dispose(lab);
+           End;
+         inherited done;
+      end;
+{****************************************************************************
+                               TAI_EXTENDED
+ ****************************************************************************}
+
+    constructor tai_extended.init(_value : bestreal);
+
+      begin
+         inherited init;
+         typ:=ait_real_extended;
+         value:=_value;
+      end;
+
+
+{****************************************************************************
+                               TAI_COMP
+ ****************************************************************************}
+
+    constructor tai_comp.init(_value : bestreal);
+
+      begin
+         inherited init;
+         typ:=ait_comp;
+         value:=_value;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:13  root
+  Initial revision
+
+  Revision 1.13  1998/03/10 01:17:20  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.12  1998/03/09 12:58:11  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.11  1998/03/06 00:52:24  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.10  1998/03/02 01:48:43  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.9  1998/02/13 10:35:09  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.8  1998/02/12 11:50:13  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.7  1998/01/11 03:38:05  carl
+  * bugfix op_reg_const , op3t was never initialized
+
+  Revision 1.3  1997/12/09 13:46:42  carl
+  + renamed pai_labeled68k --> pai_labeled
+  + added extended size constant
+
+  Revision 1.2  1997/11/28 18:14:37  pierre
+   working version with several bug fixes
+
+  Revision 1.1.1.1  1997/11/27 08:32:57  michael
+  FPC Compiler CVS start
+
+
+  Pre-CVS log:
+
+  History:
+      30th september 1996:
+     + unit started
+      15th october 1996:
+     + tai386 added
+     + some code from asmgen moved to this unit
+      26th november 1996:
+     + tai386_labeled
+    ---------------------
+      3rd september 1997:
+     + unit started
+      5th september 1997:
+     + first version completed
+     24 september 1997:
+     + minor fixes regarding register conventions (CEC)
+     26 september 1997:
+     + added divs/muls tai68k constructor (CEC)
+     + added mc68020 instruction types (CEC)
+     + converted to work with v093 (CEC)
+    4th october 1997:
+    + version v95 (CEC)
+    + added floating point flags (CEC)
+    + added op_reg_const opcode for LINK instruction. (CEC)
+    + added floating point branch / flags (CEC)
+   2nd november 1997:
+     + instruction set for the 68000/68020/common FPU/common MMU is
+       now supposedely complete. (CEC).
+    20th november 1997:
+    * changed LOC_FPUREGISTER to LOC_FPU same as in i386.pas (PM)
+
+  What is left to do:
+    o  Create an opcode table to use in direct object output.
+    o  Create an instruction template for MOVEM instruction.
+
+}

compiler/makecfg

@@ -0,0 +1,14 @@
+#!/bin/sh
+# Generate a configuration file for ppc386, write to ppc386.cfg
+# Needs 2 argument : 
+# 1) The directory where the libraries are. (without linuxunits appended)
+# 2) The directory where libgcc.a is.
+#
+# Michael Van Canneyt, 1996
+#
+cat <<EOF >ppc386.cfg
+-TLINUX
+-Fr$1/errorE.msg
+-Fg$2
+-Up$1/linuxunits
+EOF

compiler/makefile

@@ -0,0 +1,482 @@
+#****************************************************************************
+#
+#		    Copyright (c) 1993,95 by Florian Klaempfl
+#		     Modified and enhanced for GNU make by
+#			  M. Van Canneyt and P. Muller
+#****************************************************************************
+#
+# The parameters are set in the main makefile.
+# here we specify the defaults.
+
+#############################
+# When compiling the compiler
+#############################
+
+# Try to determine Operating System
+
+BASEDIR:=$(shell pwd)
+# in linux no : in pathes
+ifeq ($(findstring, ':', $(BASEDIR)),)
+inlinux=1
+endif
+
+# in case pwd is not present on the DOS-OS
+ifeq ($(strip $(BASEDIR)),'')
+undef inlinux
+BASEDIR:=.
+endif
+
+# What compiler to use
+ifndef PP
+PP=ppc386
+endif
+
+# what target do we use
+# currently dos go32v2 os2 and linux are available
+ifdef inlinux
+TARGET=linux
+else
+TARGET=go32v2
+endif
+
+COMPILERDIR=$(BASEDIR)
+
+# What extra options to give to compiler ?
+# (Minimum options are added by the makefile itself)
+ifndef OPT
+# OPT= -g
+# for aout
+# OPT= -e/usr/i486-linuxaout/bin -a -Sg -OGa  -g -q+ -w- -Up$(UNITDIR)
+endif
+
+# What processor do you want to compile for : i386 m68k (case sensitive !!)
+ifndef CPU
+CPU= i386
+# CPU= m68k
+endif
+
+RTLDIR:=$(BASEDIR)/../rtl
+
+# specify where units are.
+# This needs to be set correctly for the 'remake' target to work !
+ifndef UNITDIR
+UNITDIR=$(RTLDIR)/$(TARGET)
+#UNITDIR=/usr/lib/ppc/0.99.0/linuxunits
+# dos and go32v2 are special
+ifeq ($(TARGET),dos)
+UNITDIR=$(RTLDIR)/dos/go32v1
+endif
+ifeq ($(TARGET),go32v2)
+UNITDIR=$(RTLDIR)/dos/go32v2
+endif
+endif
+# not def UNITDIR
+
+# Where to install the executable program/link
+ifndef PROGINSTALLDIR
+ifdef inlinux
+PROGINSTALLDIR = /usr/local/bin
+else
+PROGINSTALLDIR = c:\pp\bin
+endif
+endif
+
+# Linux only : Where to install the _real_executable.
+ifndef LIBINSTALLDIR
+LIBINSTALLDIR = /usr/lib/ppc/0.99.0
+# for aout system
+# LIBINSTALLDIR = /usr/lib/ppc/aout/0.9.1
+endif
+
+# !!! Linux only
+# GCCLIBPATH is wat is it on my PC... it MUST be set in the main Makefile
+ifndef GCCLIBPATH
+GCCLIBPATH=/usr/lib/gcc-lib/i486-linux/2.6.3
+endif
+
+##################################
+# When making diffs of the sources
+##################################
+
+# Diff program
+DIFF = diff
+
+# Diff3 program
+DIFF3 = diff3
+
+# Options to diff.
+DIFFOPTS = -b -c
+
+# Directory where files are to make diffs with..
+ifdef inlinux
+DIFDIR = /usr/local/fpk/work/new/compiler
+else
+DIFDIR = h:/cvs/compiler
+endif
+
+# Directory where reference files are for diff3
+ifdef inlinux
+REFDIR = /usr/local/fpk/dist/source/compiler
+else
+REFDIR = h:/myref/compiler
+endif
+
+#####################################################################
+# End of configurable section. Do not edit after this line.
+#####################################################################
+
+# correct options with needed stuff
+PPOPTS:=$(OPT) -d$(CPU) -dGDB -dFPC -Sg 
+
+ifneq ("$(UNITDIR)", "")
+PPOPTS:=$(PPOPTS) -Up$(UNITDIR)
+endif
+
+COMPILER = $(PP) $(PPOPTS)
+
+# Do we need the GCC library ?
+ifeq ($(LINK_TO_C),YES)
+COMPILER:=$(COMPILER) -Fg$(GCCLIBPATH)
+endif
+
+.SUFFIXES: .pas .exe .ppu .dif .d3p .d3i .d3m .new
+
+.PHONY : diff diff3 patch clean rtl toflor \
+	test rtlzip remake3 remake cycle \
+	info replacediff3 restorediff3
+
+
+.pas.ppu:
+	$(COMPILER) $<
+
+.pas.exe:
+	$(COMPILER) $<
+
+.pas:
+	$(COMPILER) $<
+
+#
+# Default target makes the compiler.
+#
+
+ifeq ($(TARGET),linux)
+PPEXENAME=pp
+EXENAME=ppc386
+TEMPNAME=ppc
+TEMPNAME1=ppc1
+TEMPNAME2=ppc2
+TEMPNAME3=ppc3
+MAKEDEP=mkdep
+REPLACE=mv -f
+else
+PPEXENAME=pp.exe
+EXENAME=ppc386.exe
+TEMPNAME=ppc.exe
+TEMPNAME1=ppc1.exe
+TEMPNAME2=ppc2.exe
+TEMPNAME3=ppc3.exe
+MAKEDEP=mkdep.exe
+# DJGPP mv -f make problems under dos !!
+REPLACE=move /y
+endif
+CP=cp -f
+
+all : $(EXENAME)
+
+PASFILES:=$(shell ls *.pas)
+
+INCFILES:=$(shell ls *.inc)
+
+MSGFILES:=$(shell ls *.msg)
+
+info :
+	@echo Target is $(TARGET)
+	@echo basedir is $(BASEDIR)
+	@echo Pascal files are $(PASFILES)
+	@echo Inc files are $(INCFILES)
+	@echo Msg files are $(MSGFILES)
+
+ifdef inlinux 
+$(MAKEDEP) : $(RTLDIR)/utils/mkdep.pp
+	$(PP) $(RTLDIR)/utils/mkdep.pp
+	$(CP) $(RTLDIR)/utils/$(MAKEDEP) $(MAKEDEP)
+
+dependencies : $(MAKEDEP)
+	$(MAKEDEP) pp.pas $(PPOPTS) > depend
+
+include depend
+endif
+
+ifdef inlinux
+$(EXENAME) : $(PPEXENAME)
+	$(REPLACE) $(PPEXENAME) $(EXENAME)
+else
+$(EXENAME) : $(PASFILES) $(INCFILES) $(MSGFILES)
+	$(COMPILER) pp.pas
+	$(REPLACE) $(PPEXENAME) $(EXENAME)
+endif
+
+#
+# This target remakes the units with the currently made version
+#
+remake: $(EXENAME)
+	$(REPLACE) $(EXENAME) $(TEMPNAME)
+	$(MAKE) clean
+	$(MAKE) -C $(UNITDIR) clean
+	$(MAKE) -C $(UNITDIR) 'PP=$(COMPILERDIR)/$(TEMPNAME)' all
+	$(MAKE) 'PP=./$(TEMPNAME)' all
+
+remake3: $(TEMPNAME3)
+	$(MAKE) clean
+	$(MAKE) -C $(UNITDIR) clean
+	$(MAKE) -C $(UNITDIR) 'PP=$(COMPILERDIR)/$(TEMPNAME3)' all
+	$(MAKE) 'PP=./$(TEMPNAME3)' all
+	diff $(TEMPNAME3) $(EXENAME)
+
+$(TEMPNAME1) : $(EXENAME)
+	$(REPLACE) $(EXENAME) $(TEMPNAME1)
+
+$(TEMPNAME2) : $(TEMPNAME1)
+	$(MAKE) clean
+	$(MAKE) -C $(UNITDIR) clean
+	$(MAKE) -C $(UNITDIR) 'PP=$(COMPILERDIR)/$(TEMPNAME1)' all
+	$(MAKE) 'PP=./$(TEMPNAME1)' all
+	$(REPLACE) $(EXENAME) $(TEMPNAME2)
+
+$(TEMPNAME3) : $(TEMPNAME2)
+	$(MAKE) clean
+	$(MAKE) -C $(UNITDIR) clean
+	$(MAKE) -C $(UNITDIR) 'PP=$(COMPILERDIR)/$(TEMPNAME2)' all
+	$(MAKE) 'PP=./$(TEMPNAME2)' all
+	$(REPLACE) $(EXENAME) $(TEMPNAME3)
+
+cycle:
+	$(MAKE) clean
+	$(MAKE) -C $(UNITDIR) clean
+	$(MAKE) -C $(UNITDIR)
+	$(MAKE) remake3
+
+install : all
+	install -m 755 -d $(LIBINSTALLDIR)
+	install -m 755 ppc386 $(LIBINSTALLDIR)
+	ln -sf $(LIBINSTALLDIR)/ppc386 $(PROGINSTALLDIR)/ppc386
+	makecfg $(LIBINSTALLDIR) $(GCCLIBPATH)
+	install -m 644 ppc386.cfg /etc
+	install -m 644 errorE.msg $(LIBINSTALLDIR)
+	@echo Wrote sample configuration file to /etc
+
+clean :
+ifdef inlinux
+	-rm -f *.o *.ppu *.s $(EXENAME) ppc386.cfg
+else
+	-rm -f *.o *.ppu *.s $(EXENAME)
+endif
+
+dist :
+	mkdir $(DISTDIR)/compiler
+	cp *.pas *.inc makecfg Makefile depend errorE.msg $(DISTDIR)/compiler
+
+#
+# Utilities for making archives.
+#
+SOURCEFILES = $(PASFILES) $(INCFILES) $(MSGFILES) Makefile
+
+DIFFFILES = $(patsubst %.pas,%.dif,$(PASFILES)) \
+	$(patsubst %.inc,%.dif,$(INCFILES)) \
+	$(patsubst %.msg,%.dif,$(MSGFILES)) \
+	Makefile.dif
+
+DIFF3FILES = $(patsubst %.pas,%.d3p,$(PASFILES)) \
+	$(patsubst %.inc,%.d3i,$(INCFILES)) \
+	$(patsubst %.msg,%.d3m,$(MSGFILES)) \
+	Makefile.di3
+
+PATCHFILES = $(patsubst %.pas,%.new,$(PASFILES)) \
+	$(patsubst %.inc,%.new,$(INCFILES)) \
+	$(patsubst %.msg,%.new,$(MSGFILES)) \
+	Makefile.new
+
+%.dif : %.pas
+	-$(DIFF) $(DIFFOPTS) $*.pas $(DIFDIR)/$*.pas   > $*.dif
+
+%.dif : %.msg
+	-$(DIFF) $(DIFFOPTS) $*.msg $(DIFDIR)/$*.msg   > $*.dif
+
+%.dif : %.inc
+	-$(DIFF) $(DIFFOPTS) $*.inc $(DIFDIR)/$*.inc   > $*.dif
+
+Makefile.dif : Makefile
+	-$(DIFF) $(DIFFOPTS) Makefile $(DIFDIR)/Makefile   > Makefile.dif
+
+%.new : %.pas %.dif
+	-copy /y $*.pas $*.new
+	-patch $*.new $*.dif
+
+%.new : %.msg %.dif
+	-copy /y $*.msg $*.new
+	-patch $*.new $*.dif
+
+%.new : %.inc %.dif
+	-copy /y $*.inc $*.new
+	-patch $*.new $*.dif
+
+Makefile.new : Makefile Makefile.dif
+	-copy /y Makefile Makefile.new
+	-patch Makefile.new Makefile.dif
+
+%.d3p : %.pas
+	-$(DIFF3) -m -E $*.pas $(REFDIR)/$*.pas $(DIFDIR)/$*.pas > $*.d3p
+
+%.d3m : %.msg
+	-$(DIFF3) -m -E $*.msg $(REFDIR)/$*.msg $(DIFDIR)/$*.msg > $*.d3m
+
+%.d3i : %.inc
+	-diff3 -m -E $*.inc $(REFDIR)/$*.inc $(DIFDIR)/$*.inc > $*.d3i
+
+Makefile.di3: Makefile
+	-diff3 -m -E Makefile $(REFDIR)/Makefile $(DIFDIR)/Makefile > Makefile.di3
+
+diff : $(DIFFFILES)
+
+diff3 : $(DIFF3FILES)
+
+replacediff3 : diff3
+	copy /y *.pas *.bkp
+	copy /y *.inc *.bki
+	copy /y *.msg *.bkm
+	copy /y Makefile Makefile.old
+	copy /y *.d3p *.pas
+	copy /y *.d3i *.inc
+	copy /y *.d3m *.msg
+	copy /y Makefile.di3 Makefile
+
+restorediff3 : 
+	copy /y *.bkp *.pas 
+	copy /y *.bki *.inc
+	copy /y *.bkm *.msg
+	copy /y Makefile.old Makefile
+
+
+patch : $(PATCHFILES)
+
+diffclean :
+	-del *.dif
+	-del *.di3
+	-del *.new
+
+rtl :
+	make -C $(UNITDIR) all
+
+rtlclean :
+	make -C $(UNITDIR) clean
+
+################################################
+##  Just an easy way to handle the diffs
+##  I just use the tiny program cpne.pp
+##  that copy to directory toflor all .dif files
+##  that are not empty
+##  empty files are deleted
+##  I did not find any direct way to do this !! (PM)
+#################################################
+
+#########################
+# When	making zip files
+#########################
+
+# Zip program
+ifdef inlinux
+ZIP = zip
+else
+ZIP = c:/pak/zip/zip386
+endif
+
+# Unzip program
+ifdef inlinux
+UNZIP = unzp
+else
+UNZIP= c:/pak/zip/unzip
+endif
+
+DIF=v97
+
+toflor : diff
+	-rm toflor/*.dif
+	cpne *.dif toflor
+	cp Makefile toflor/Makefile
+	cp cpne.pp toflor/cpne.pp
+	cd toflor
+	zip dif2$(DIF) *.dif Makefile cpne.pp
+	cd ..
+
+src_comp.zip : $(SOURCEFILES)
+	$(ZIP) -u src_comp $(SOURCEFILES)
+
+#################################################
+# Obsolete
+# does not contains all directories
+#################################################
+rtlzip :
+	echo rtl\Makefile >rtl.cfg
+	echo rtl\readme >>rtl.cfg
+	echo rtl\cfg\Makefile >>rtl.cfg
+	echo rtl\cfg\readme >>rtl.cfg
+	echo rtl\cfg\*.cfg >>rtl.cfg
+	echo rtl\inc\Makefile >>rtl.cfg
+	echo rtl\inc\readme >>rtl.cfg
+	echo rtl\inc\*.pp >>rtl.cfg
+	echo rtl\inc\*.inc >>rtl.cfg
+	echo rtl\i386\Makefile >>rtl.cfg
+	echo rtl\i386\readme >>rtl.cfg
+	echo rtl\i386\*.pp >>rtl.cfg
+	echo rtl\i386\*.inc >>rtl.cfg
+	echo rtl\m68k\Makefile >>rtl.cfg
+	echo rtl\m68k\readme >>rtl.cfg
+	echo rtl\m68k\*.pp >>rtl.cfg
+	echo rtl\m68k\*.inc >>rtl.cfg
+	echo rtl\template\Makefile >>rtl.cfg
+	echo rtl\template\readme >>rtl.cfg
+	echo rtl\template\*.pp >>rtl.cfg
+	echo rtl\template\*.pas >>rtl.cfg
+	echo rtl\template\*.inc >>rtl.cfg
+	echo rtl\dos\Makefile >>rtl.cfg
+	echo rtl\dos\readme >>rtl.cfg
+	echo rtl\dos\*.pp >>rtl.cfg
+	echo rtl\dos\*.inc >>rtl.cfg
+	echo rtl\dos\ppi\Makefile >>rtl.cfg
+	echo rtl\dos\ppi\readme >>rtl.cfg
+	echo rtl\dos\ppi\*.ppi >>rtl.cfg
+	echo rtl\dos\go32v2\Makefile >>rtl.cfg
+	echo rtl\dos\go32v2\readme >>rtl.cfg
+	echo rtl\dos\go32v2\*.pp >>rtl.cfg
+	echo rtl\dos\go32v2\*.inc >>rtl.cfg
+	echo rtl\dos\go32v2\sbrk16.a* >>rtl.cfg
+	echo rtl\dos\go32v2\exit16.a* >>rtl.cfg
+	echo rtl\dos\go32v2\v2prt0.as >>rtl.cfg
+	echo rtl\dos\go32v2\exceptn.as >>rtl.cfg
+	echo rtl\dos\go32v1\Makefile >>rtl.cfg
+	echo rtl\dos\go32v1\readme >>rtl.cfg
+	echo rtl\dos\go32v1\*.pp >>rtl.cfg
+	echo rtl\dos\go32v1\*.inc >>rtl.cfg
+	echo rtl\dos\go32v1\prt0.as >>rtl.cfg
+	echo rtl\linux\Makefile >>rtl.cfg
+	echo rtl\linux\readme >>rtl.cfg
+	echo rtl\linux\*.pp >>rtl.cfg
+	echo rtl\linux\*.inc >>rtl.cfg
+	echo rtl\linux\prt*.as >>rtl.cfg
+	echo rtl\os2\Makefile >>rtl.cfg
+	echo rtl\os2\readme >>rtl.cfg
+	echo rtl\os2\*.pas >>rtl.cfg
+	echo rtl\os2\*.inc >>rtl.cfg
+	echo rtl\os2\*.imp >>rtl.cfg
+	echo rtl\os2\*.a >>rtl.cfg
+	echo rtl\os2\*.btm >>rtl.cfg
+	echo rtl\os2\*.cmd >>rtl.cfg
+	echo rtl\os2\prt*.as >>rtl.cfg
+	echo rtl\os2\dosini*.as >>rtl.cfg
+	echo rtl.cfg >>rtl.cfg
+	echo rtl.txt >>rtl.cfg
+	echo Makefile >>rtl.cfg
+	cd ..
+	$(ZIP) -u rtl @rtl.cfg
+	$(UNZIP) -v rtl >rtl.lst
+cycle: clean

compiler/messages.pas

@@ -0,0 +1,229 @@
+{
+    $Id$
+    Copyright (c) 1998 by Peter Vreman
+
+    This unit implements the message object
+
+    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 Messages;
+interface
+
+type
+  ppchar=^pchar;
+
+  PMessage=^TMessage;
+  TMessage=object
+    msgfilename : string;
+    msgsize,
+    msgs        : longint;
+    msgtxt      : pchar;
+    msgidx      : ppchar;
+    constructor Init(p:pointer;n:longint);
+    constructor InitExtern(const fn:string;n:longint);
+    destructor Done;
+    function Get(nr:longint):string;
+    function Get3(nr:longint;const s1,s2,s3:string):string;
+    function Get2(nr:longint;const s1,s2:string):string;
+    function Get1(nr:longint;const s1:string):string;
+  end;
+
+implementation
+
+uses
+  strings;
+
+constructor TMessage.Init(p:pointer;n:longint);
+var
+  hp  : pchar;
+  hpl : ppchar;
+begin
+  hp:=pchar(p);
+  msgtxt:=hp;
+  msgsize:=0;
+  msgs:=n;
+  getmem(msgidx,msgs shl 2);
+  hpl:=msgidx;
+  n:=0;
+  while (n<msgs) do
+   begin
+     hpl^:=hp;
+     hpl:=pointer(longint(hpl)+4);
+     inc(n);
+     hp:=pchar(@hp[strlen(hp)+1]);
+   end;
+end;
+
+
+constructor TMessage.InitExtern(const fn:string;n:longint);
+var
+  f       : file;
+  bufread : word;
+  i,j     : longint;
+  p       : pchar;
+  hpl     : ppchar;
+begin
+  msgs:=0;
+  msgsize:=0;
+  msgidx:=nil;
+{Read the message file}
+  msgfilename:=fn;
+  assign(f,fn);
+  {$I-}
+   reset(f,1);
+  {$I+}
+  if ioresult<>0 then
+   begin
+     WriteLn('*** message file '+msgfilename+' not found ***');
+     exit;
+   end;
+  msgsize:=filesize(f);
+  getmem(msgtxt,msgsize+1);
+  blockread(f,msgtxt^,msgsize,bufread);
+  msgtxt[msgsize]:=#10;
+  close(f);
+  inc(msgsize);
+{Parse buffer in msgtxt and create indexs}
+  msgs:=n;
+  getmem(msgidx,msgs shl 2);
+  hpl:=msgidx;
+  p:=msgtxt;
+  i:=0;
+  n:=0;
+  while (i<bufread) and (n<msgs) do
+   begin
+     j:=0;
+     while (not (p[j] in [#10,#13])) and (j<255) and (i<bufread) do
+      begin
+        inc(i);
+        inc(j);
+      end;
+     if not (p[0] in [';','#']) then
+      begin
+        hpl^:=p;
+        hpl:=pointer(longint(hpl)+4);
+        inc(n);
+        if (p[0]='<') and (p[1]='l') and (p[2]='f') and (p[3]='>') then
+         p[0]:=#0
+        else
+         p[j]:=#0;
+      end;
+     repeat
+       inc(i);
+       inc(j);
+     until not (p[j] in [#10,#13]);
+     p:=pchar(@p[j]);
+   end;
+end;
+
+
+
+destructor TMessage.Done;
+begin
+  if not (msgidx=nil) then
+   freemem(msgidx,msgs shl 2);
+  if msgsize>0 then
+   freemem(msgtxt,msgsize);
+end;
+
+
+function TMessage.Get(nr:longint):string;
+var
+  s : string[16];
+  hp : pchar;
+begin
+  if msgidx=nil then
+   hp:=nil
+  else
+   hp:=pchar(pointer(longint(msgidx)+nr shl 2)^);
+  if hp=nil then
+   begin
+     Str(nr,s);
+     Get:='msg nr '+s;
+   end
+  else
+   Get:=StrPas(hp);
+end;
+
+
+function TMessage.Get3(nr:longint;const s1,s2,s3:string):string;
+var
+  i : longint;
+  s : string;
+begin
+  s:=Get(nr);
+{ $1 -> s1 }
+  repeat
+    i:=pos('$1',s);
+    if i>0 then
+     begin
+       Delete(s,i,2);
+       Insert(s1,s,i);
+     end;
+  until i=0;
+{ $2 -> s2 }
+  repeat
+    i:=pos('$2',s);
+    if i>0 then
+     begin
+       Delete(s,i,2);
+       Insert(s2,s,i);
+     end;
+  until i=0;
+{ $3 -> s3 }
+  repeat
+    i:=pos('$3',s);
+    if i>0 then
+     begin
+       Delete(s,i,2);
+       Insert(s3,s,i);
+     end;
+  until i=0;
+  Get3:=s;
+end;
+
+
+function TMessage.Get2(nr:longint;const s1,s2:string):string;
+begin
+  Get2:=Get3(nr,s1,s2,'');
+end;
+
+
+function TMessage.Get1(nr:longint;const s1:string):string;
+begin
+  Get1:=Get3(nr,s1,'','');
+end;
+
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:13  root
+  Initial revision
+
+  Revision 1.3  1998/03/10 01:17:20  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.2  1998/03/05 02:44:12  peter
+    * options cleanup and use of .msg file
+
+  Revision 1.1  1998/03/02 01:55:19  peter
+    + Initial implementation
+
+}

compiler/mppc386.bat

@@ -0,0 +1,6 @@
+ppc386 -Ch8000000 -dI386 -dGDB -a -Sg pp.pas %1 %2 %3 %4 %5 %6 %7 %8 %9
+if errorlevel 0 goto success
+goto failed
+:success
+copy pp.exe ppc386.exe
+:failed

compiler/mppc68k.bat

@@ -0,0 +1,2 @@
+ppc386 -Ch8000000 -dm68k -dGDB -a -Sg pp.pas %1 %2 %3 %4 %5 %6 %7 %8 %9
+copy pp.exe ppc68k.exe

compiler/msgidx.inc

@@ -0,0 +1,456 @@
+{
+    $Id$
+    Copyright (c) 1998 by the FPC development team
+
+    This file includes the message index types which can be used to display
+    a message from the message file
+
+    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.
+
+ ****************************************************************************}
+
+{
+  The constants are build in the following order:
+  <part>_<type>_<txtidentifier>
+
+  <part> is the part of the compiler the message is used
+    assem_    assembler parsing
+    unit_     unit handling
+    scan_     scanner
+    general_  general info
+    exec_     calls to assembler, linker, binder
+
+  <type> the type of the message it should normally used for
+    f_   fatal error
+    e_   error
+    w_   warning
+    n_   note
+    h_   hint
+    i_   info
+    l_   linenumber
+    u_   used
+    t_   tried
+    m_   macro
+    p_   procedure
+    c_   conditional
+    d_   debug message
+
+  syn_ means a syntax error
+}
+type
+  tmsgconst = (
+general_i_kb_free,
+general_l_lines_and_free,
+general_i_stream_kb_free,
+general_i_ems_kb_free,
+general_i_compilername,
+general_i_unitsearchpath,
+general_d_sourceos,
+general_i_targetos,
+general_u_exepath,
+general_u_gcclibpath,
+general_i_abslines_compiled,
+{
+  Scanner part
+}
+scan_f_end_of_file,
+scan_f_string_exceeds_line,
+scan_f_illegal_char,
+scan_f_syn_expected,
+scan_u_start_include_file,
+scan_w_comment_level,
+scan_n_far_directive_ignored,
+scan_n_stack_check_global_under_linux,
+scan_w_illegal_switch,
+scan_w_switch_is_global,
+scan_e_illegal_char_const,
+scan_f_cannot_open_input,
+scan_f_cannot_open_includefile,
+scan_e_too_much_endifs,
+scan_w_only_pack_records,
+scan_e_endif_expected,
+scan_e_preproc_syntax_error,
+scan_e_error_in_preproc_expr,
+scan_w_marco_cut_after_255_chars,
+scan_e_endif_without_if,
+scan_f_user_defined,
+scan_e_user_defined,
+scan_w_user_defined,
+scan_n_user_defined,
+scan_h_user_defined,
+scan_i_user_defined,
+scan_e_keyword_cant_be_a_macro,
+scan_f_macro_buffer_overflow,
+scan_w_macro_deep_ten,
+scan_e_wrong_styled_switch,
+scan_d_handling_switch,
+scan_c_endif_found,
+scan_c_ifdef_found,
+scan_c_ifopt_found,
+scan_c_if_found,
+scan_c_ifndef_found,
+scan_c_else_found,
+scan_c_skipping_until,
+scan_i_press_enter,
+{
+  Parser
+}
+parser_e_syntax_error,
+parser_w_proc_far_ignored,
+parser_w_proc_near_ignored,
+parser_e_no_dll_file_specified,
+parser_e_constructorname_must_be_init,
+parser_e_destructorname_must_be_done,
+parser_e_illegal_open_parameter,
+parser_e_proc_inline_not_supported,
+parser_w_priv_meth_not_virtual,
+parser_e_constructor_cannot_be_private,
+parser_e_destructor_cannot_be_private,
+parser_n_only_one_destructor,
+parser_e_no_local_objects,
+parser_e_no_anonym_objects,
+parser_e_ordinal_expected,
+parser_e_illegal_parameter_list,
+parser_e_overloaded_no_procedure,
+parser_e_overloaded_have_same_parameters,
+parser_e_header_dont_match_forward,
+parser_n_duplicate_enum,
+parser_n_interface_name_diff_implementation_name,
+parser_e_too_much_lexlevel,
+parser_e_range_check_error,
+parser_e_pointer_type_expected,
+parser_e_class_type_expected,
+parser_e_double_caselabel,
+parser_e_type_const_not_possible,
+parser_e_no_overloaded_procvars,
+parser_e_string_too_long,
+parser_w_use_extended_syntax_for_objects,
+parser_e_class_id_expected,
+parser_e_methode_id_expected,
+parser_e_header_dont_match_any_member,
+parser_p_procedure_start,
+parser_e_error_in_real,
+parser_e_fail_only_in_constructor,
+parser_e_no_paras_for_destructor,
+parser_e_strict_var_string_violation,
+parser_e_only_class_methods_via_class_ref,
+parser_e_only_class_methods,
+parser_e_case_mismatch,
+parser_e_illegal_symbol_exported,
+parser_e_must_use_override,
+parser_e_nothing_to_be_overridden,
+parser_e_no_procedure_to_access_property,
+parser_e_ill_property_access_sym,
+parser_e_cant_write_protected_member,
+parser_e_overloaded_are_not_both_virtual,
+parser_e_overloaded_methodes_not_same_ret,
+parser_e_dont_nest_export,
+parser_e_methods_dont_be_export,
+parser_e_call_by_ref_without_typeconv,
+parser_e_no_super_class,
+parser_e_self_not_in_method,
+parser_e_generic_methods_only_in_methods,
+parser_e_illegal_colon_qualifier,
+parser_e_illegal_set_expr,
+parser_e_pointer_to_class_expected,
+parser_e_expr_have_to_be_constructor_call,
+parser_e_expr_have_to_be_destructor_call,
+parser_e_typeconflict_in_set,
+parser_w_use_int_div_int_op,
+parser_e_invalid_record_const,
+parser_e_false_with_expr,
+parser_e_void_function,
+parser_e_constructors_always_objects,
+parser_w_convert_real_2_comp,
+parser_e_operator_not_overloaded,
+parser_e_varid_or_typeid_expected,
+parser_e_no_reraise_possible,
+parser_e_no_new_or_dispose_for_classes,
+parser_e_asm_incomp_with_function_return,
+parser_e_procedure_overloading_is_off,
+parser_e_overload_operator_failed,
+parser_e_comparative_operator_return_boolean,
+parser_e_only_virtual_methods_abstract,
+parser_f_unsupported_feature,
+parser_e_mix_of_classes_and_objects,
+parser_w_unknown_proc_directive_ignored,
+parser_e_absolute_only_one_var,
+parser_e_absolute_only_to_var_or_const,
+parser_e_abstract_no_definition,
+parser_e_overloaded_must_be_all_global,
+parser_e_succ_and_pred_enums_with_assign_not_possible,
+parser_w_virtual_without_constructor,
+parser_m_macro_defined,
+parser_m_macro_undefined,
+parser_m_macro_set_to,
+parser_i_compiling,
+parser_d_compiling_second_time,
+parser_e_no_paras_allowed,
+parser_e_no_property_found_to_override,
+parser_e_only_one_default_property,
+parser_e_property_need_paras,
+{
+  Symbol table
+}
+sym_n_local_var_not_init_yet,
+sym_e_id_not_found,
+sym_f_internal_error_in_symtablestack,
+sym_e_duplicate_id,
+sym_e_unknown_id,
+sym_e_forward_not_resolved,
+sym_f_id_already_typed,
+sym_e_type_id_expected,
+sym_e_type_mismatch,
+sym_e_error_in_type_def,
+sym_e_type_id_not_defined,
+sym_e_only_static_in_static,
+sym_e_invalid_call_tvarsymmangledname,
+sym_f_type_must_be_rec_or_class,
+sym_e_no_instance_of_abstract_object,
+sym_e_label_not_defined,
+sym_e_ill_label_decl,
+sym_e_goto_and_label_not_supported,
+sym_e_label_not_found,
+sym_e_id_is_no_label_id,
+sym_e_label_already_defined,
+sym_e_ill_type_decl_set,
+sym_e_class_forward_not_resolved,
+sym_h_identifier_not_used,
+sym_e_set_element_are_not_comp,
+sym_e_set_expected,
+sym_w_function_result_not_set,
+sym_e_illegal_field,
+sym_n_uninitialized_local_variable,
+sym_e_id_no_member,
+{
+  Codegenerator
+}
+cg_e_break_not_allowed,
+cg_e_continue_not_allowed,
+cg_e_too_complex_expr,
+cg_e_illegal_expression,
+cg_e_invalid_integer,
+cg_e_invalid_qualifier,
+cg_e_upper_lower_than_lower,
+cg_e_illegal_count_var,
+cg_e_cant_choose_overload_function,
+cg_e_parasize_too_big,
+cg_e_illegal_type_conversion,
+cg_e_file_must_call_by_reference,
+cg_e_cant_use_far_pointer_there,
+cg_e_var_must_be_reference,
+cg_e_dont_call_exported_direct,
+cg_w_member_cd_call_from_method,
+cg_n_inefficient_code,
+cg_w_unreachable_code,
+cg_e_stackframe_with_esp,
+cg_e_cant_call_abstract_method,
+cg_f_internal_error_in_getfloatreg,
+cg_f_unknown_float_type,
+cg_f_secondvecn_base_defined_twice,
+cg_f_extended_cg68k_not_supported,
+cg_f_32bit_not_supported_in_68000,
+cg_f_internal_error_in_secondinline,
+cg_d_register_weight,
+cg_e_stacklimit_in_local_routine,
+cg_d_stackframe_omited,
+{
+  Assembler parsers
+}
+assem_f_ev_zero_divide,
+assem_f_ev_stack_overflow,
+assem_f_ev_stack_underflow,
+assem_f_ev_invalid_number,
+assem_f_ev_invalid_op,
+assem_f_ev_unknown,
+assem_w_invalid_numeric,
+assem_e_escape_seq_ignored,
+assem_e_syn_prefix_not_found,
+assem_e_syn_try_add_more_prefix,
+assem_e_syn_opcode_not_found,
+assem_e_invalid_symbol_ref,
+assem_w_calling_overload_func,
+assem_e_constant_out_of_bounds,
+assem_e_none_label_contain_at,
+assem_e_invalid_operand,
+assem_w_override_op_not_supported,
+assem_e_error_in_binary_const,
+assem_e_error_in_octal_const,
+assem_e_error_in_hex_const,
+assem_e_error_in_integer_const,
+assem_e_invalid_labeled_opcode,
+assem_f_internal_error_in_findtype,
+assem_e_invalid_size_movzx,
+assem_e_16bit_base_in_32bit_segment,
+assem_e_16bit_index_in_32bit_segment,
+assem_e_invalid_opcode,
+assem_e_const_ref_not_allowed,
+assem_w_fwait_emu_prob,
+assem_e_invalid_opcode_and_operand,
+assem_w_opcode_not_in_table,
+assem_f_internal_error_in_concatopcode,
+assem_e_invalid_size_in_ref,
+assem_e_invalid_middle_sized_operand,
+assem_e_invalid_three_operand_opcode,
+assem_e_syntax_error,
+assem_e_invalid_operand_type,
+assem_e_segment_override_not_supported,
+assem_e_invalid_const_symbol,
+assem_f_error_converting_bin,
+assem_f_error_converting_hex,
+assem_f_error_converting_octal,
+assem_e_invalid_constant_expression,
+assem_e_unknown_id,
+assem_e_defining_index_more_than_once,
+assem_e_invalid_field_specifier,
+assem_f_internal_error_in_buildscale,
+assem_e_invalid_scaling_factor,
+assem_e_invalid_scaling_value,
+assem_e_scaling_value_only_allowed_with_index,
+assem_e_syn_no_ref_with_brackets,
+assem_e_expression_form_not_supported,
+assem_e_defining_seg_more_than_once,
+assem_e_defining_base_more_than_once,
+assem_e_negative_index_register,
+assem_e_syn_reference,
+assem_e_local_symbol_not_allowed_as_ref,
+assem_e_invalid_operand_in_bracket_expression,
+assem_e_invalid_symbol_name,
+assem_e_invalid_reference_syntax,
+assem_e_invalid_string_as_opcode_operand,
+assem_w_CODE_and_DATA_not_supported,
+assem_e_null_label_ref_not_allowed,
+assem_e_cannot_use_SELF_outside_a_method,
+assem_e_syn_start_with_bracket,
+assem_e_syn_register,
+assem_e_SEG_and_OFFSET_not_supported,
+assem_e_syn_opcode_operand,
+assem_e_invalid_string_expression,
+assem_e_expression_out_of_bounds,
+assem_f_internal_error_in_buildconstant,
+assem_w_repeat_prefix_and_seg_override,
+assem_e_invalid_or_missing_opcode,
+assem_e_invalid_prefix_and_opcode,
+assem_e_invalid_override_and_opcode,
+assem_e_too_many_operands,
+assem_e_dup_local_sym,
+assem_e_unknown_label_identifer,
+assem_e_assemble_node_syntax_error,
+assem_e_unknown_local_sym,
+assem_d_start_intel,
+assem_d_finish_intel,
+assem_e_not_directive_or_local_symbol,
+assem_e_slash_at_begin_of_line_not_allowed,
+assem_e_nor_not_supported,
+assem_e_invalid_fpu_register,
+assem_w_modulo_not_supported,
+assem_e_invalid_float_const,
+assem_e_size_suffix_and_dest_reg_dont_match,
+assem_f_internal_error_in_concatlabeledinstr,
+assem_w_float_bin_ignored,
+assem_w_float_hex_ignored,
+assem_w_float_octal_ignored,
+assem_e_invalid_real_const,
+assem_e_parenthesis_are_not_allowed,
+assem_e_invalid_reference,
+assem_e_cannot_use___SELF_outside_methode,
+assem_e_cannot_use___OLDEBP_outside_nested_procedure,
+assem_w_id_supposed_external,
+assem_e_invalid_seg_override,
+assem_e_string_not_allowed_as_const,
+assem_d_start_att,
+assem_d_finish_att,
+assem_e_switching_sections_not_allowed,
+assem_e_invalid_global_def,
+assem_e_line_separator_expected,
+assem_w_globl_not_supported,
+assem_w_align_not_supported,
+assem_w_lcomm_not_supported,
+assem_w_comm_not_supported,
+assem_e_invalid_lcomm_def,
+assem_e_invalid_comm_def,
+assem_e_local_sym_not_found_in_asm_statement,
+assem_e_assembler_code_not_returned_to_text,
+assem_f_internal_error_in_buildreference,
+assem_e_invalid_opcode_size,
+assem_w_near_ignored,
+assem_w_far_ignored,
+assem_d_creating_lookup_tables,
+assem_w_using_defined_as_local,
+assem_f_internal_error_in_handleextend,
+assem_e_invalid_char_smaller,
+assem_e_invalid_char_greater,
+assem_e_unsupported_opcode,
+assem_e_no_inc_and_dec_together,
+assem_e_invalid_reg_list_in_movem,
+assem_e_invalid_reg_list_for_opcode,
+assem_e_68020_mode_required,
+assem_d_start_motorola,
+assem_d_finish_motorola,
+assem_w_xdef_not_supported,
+assem_w_void_function,
+assem_f_invalid_suffix_intel,
+assem_e_extended_not_supported,
+assem_e_comp_not_supported,
+assem_w_mmxwarning_as_281,
+{
+  Exec, assembler, linker, binder calls
+}
+exec_i_assembling_pipe,
+exec_d_cant_create_asmfile,
+exec_w_assembler_not_found,
+exec_u_using_assembler,
+exec_w_error_while_assembling,
+exec_w_cant_call_assembler,
+exec_i_assembling,
+exec_w_linker_not_found,
+exec_u_using_linker,
+exec_e_objfile_not_found,
+exec_w_error_while_linking,
+exec_w_cant_call_linker,
+exec_i_linking,
+exec_w_binder_not_found,
+exec_w_ar_not_found,
+exec_e_dll_not_supported,
+exec_i_closing_script,
+{
+  Unit handling, PPU File
+}
+unit_u_ppu_loading,
+unit_d_ppu_time,
+unit_d_ppu_file_too_short,
+unit_d_ppu_invalid_header,
+unit_d_ppu_invalid_version,
+unit_d_ppu_flags,
+unit_d_ppu_crc,
+unit_t_ppu_source,
+unit_d_obj_and_asm_are_older_than_ppu,
+unit_d_obj_is_older_than_asm,
+unit_t_unitsearch,
+unit_u_ppu_write,
+unit_f_ppu_cannot_write,
+unit_f_ppu_read_error,
+unit_f_ppu_invalid_entry,
+unit_f_ppu_dbx_count_problem,
+unit_e_illegal_unit_name,
+unit_f_too_much_units,
+unit_f_circular_unit_reference,
+unit_f_cant_compile_unit,
+unit_w_switch_us_missed,
+unit_e_total_errors,
+unit_f_errors_in_unit,
+{This should be the last}
+endmsgconst
+);

compiler/msgtxt.inc

@@ -0,0 +1,924 @@
+const msgtxt : array[1..13836] of char=(
+  'I','_','$','1',' ','k','B',' ','f','r','e','e',#000,'L','_',
+  '$','1',' ','l','i','n','e','s',' ','$','2',' ','k','B',' ',
+  'f','r','e','e',#000,'I','_','$','1',' ','s','t','r','e','a',
+  'm',' ','k','B',' ','u','s','e','d',#000,'I','_','$','1',' ',
+  'E','M','S',' ','k','B',' ','u','s','e','d',#000,'I','_','C',
+  'o','m','p','i','l','e','r',':',' ','$','1',#000,'I','_','U',
+  'n','i','t','s',' ','a','r','e',' ','s','e','a','r','c','h',
+  'e','d',' ','i','n',':',' ','$','1',#000,'D','_','S','o','u',
+  'r','c','e',' ','O','S',':',' ','$','1',#000,'I','_','T','a',
+  'r','g','e','t',' ','O','S',':',' ','$','1',#000,'U','_','U',
+  's','i','n','g',' ','e','x','e','c','u','t','a','b','l','e',
+  ' ','p','a','t','h',':',' ','$','1',#000,'U','_','U','s','i',
+  'n','g',' ','G','C','C','l','i','b',' ','p','a','t','h',':',
+  ' ','$','1',#000,'I','_','$','1',' ','L','i','n','e','s',' ',
+  'c','o','m','p','i','l','e','d',',',' ','$','2',' ','s','e',
+  'c',#000,'F','_','U','n','e','x','p','e','c','t','e','d',' ',
+  'e','n','d',' ','o','f',' ','f','i','l','e',#000,'F','_','S',
+  't','r','i','n','g',' ','e','x','c','e','e','d','s',' ','l',
+  'i','n','e',#000,'F','_','i','l','l','e','g','a','l',' ','c',
+  'h','a','r','a','c','t','e','r',#000,'F','_','S','y','n','t',
+  'a','x',' ','e','r','r','o','r',' ','$','2',' ','e','x','p',
+  'e','c','t','e','d',' ','a','t',' ','c','o','l',' ','$','1',
+  #000,'U','_','S','t','a','r','t',' ','r','e','a','d','i','n',
+  'g',' ','i','n','c','l','u','d','e','f','i','l','e',' ','$',
+  '1',#000,'W','_','C','o','m','m','e','n','t',' ','l','e','v',
+  'e','l',' ','$','1',' ','f','o','u','n','d',#000,'N','_','$',
+  'F',' ','d','i','r','e','c','t','i','v','e',' ','(','F','A',
+  'R',')',' ','i','g','n','o','r','e','d',#000,'N','_','S','t',
+  'a','c','k',' ','c','h','e','c','k',' ','i','s',' ','g','l',
+  'o','b','a','l',' ','u','n','d','e','r',' ','l','i','n','u',
+  'x',#000,'W','_','I','l','l','e','g','a','l',' ','c','o','m',
+  'p','i','l','e','r',' ','s','w','i','t','c','h',#000,'W','_',
+  'T','h','i','s',' ','c','o','m','p','i','l','e','r',' ','s',
+  'w','i','t','c','h',' ','h','a','s',' ','a',' ','g','l','o',
+  'b','a','l',' ','e','f','f','e','c','t',#000,'E','_','I','l',
+  'l','e','g','a','l',' ','c','h','a','r',' ','c','o','n','s',
+  't','a','n','t',#000,'F','_','C','a','n',#039,'t',' ','o','p',
+  'e','n',' ','f','i','l','e',#000,'F','_','C','a','n',#039,'t',
+  ' ','o','p','e','n',' ','i','n','c','l','u','d','e',' ','f',
+  'i','l','e',' ','$','1',#000,'E','_','T','o','o',' ','m','a',
+  'n','y',' ','$','E','N','D','I','F','s',' ','o','r',' ','$',
+  'E','L','S','E','s',#000,'W','_','R','e','c','o','r','d','s',
+  ' ','f','i','e','l','d','s',' ','c','a','n',' ','b','e',' ',
+  'a','l','i','g','n','e','d',' ','t','o',' ','1',',','2',' ',
+  'o','r',' ','4',' ','b','y','t','e','s',' ','o','n','l','y',
+  #000,'E','_','$','E','N','D','I','F',' ','e','x','p','e','c',
+  't','e','d',' ','f','o','r',' ','$','1',' ','a','t',' ','$',
+  '2',' ','$','3',#000,'E','_','S','y','n','t','a','x',' ','e',
+  'r','r','o','r',' ','w','h','i','l','e',' ','p','a','r','s',
+  'i','n','g',' ','a',' ','c','o','n','d','i','t','i','o','n',
+  'a','l',' ','c','o','m','p','i','l','i','n','g',' ','e','x',
+  'p','r','e','s','s','i','o','n',#000,'E','_','E','v','a','l',
+  'u','a','t','i','n','g',' ','a',' ','c','o','n','d','i','t',
+  'i','o','n','a','l',' ','c','o','m','p','i','l','i','n','g',
+  ' ','e','x','p','r','e','s','s','i','o','n',#000,'W','_','M',
+  'a','c','r','o',' ','c','o','n','t','e','n','t','s',' ','i',
+  's',' ','c','u','t',' ','a','f','t','e','r',' ','c','h','a',
+  'r',' ','2','5','5',' ','t','o',' ','e','v','a','l','u','t',
+  'e',' ','e','x','p','r','e','s','s','i','o','n',#000,'E','_',
+  'E','N','D','I','F',' ','w','i','t','h','o','u','t',' ','I',
+  'F','(','N',')','D','E','F',#000,'F','_','U','s','e','r',' ',
+  'd','e','f','i','n','e','d',':',' ','$','1',#000,'E','_','U',
+  's','e','r',' ','d','e','f','i','n','e','d',':',' ','$','1',
+  #000,'W','_','U','s','e','r',' ','d','e','f','i','n','e','d',
+  ':',' ','$','1',#000,'N','_','U','s','e','r',' ','d','e','f',
+  'i','n','e','d',':',' ','$','1',#000,'H','_','U','s','e','r',
+  ' ','d','e','f','i','n','e','d',':',' ','$','1',#000,'I','_',
+  'U','s','e','r',' ','d','e','f','i','n','e','d',':',' ','$',
+  '1',#000,'E','_','K','e','y','w','o','r','d',' ','r','e','d',
+  'e','f','i','n','e','d',' ','a','s',' ','m','a','c','r','o',
+  ' ','h','a','s',' ','n','o',' ','e','f','f','e','c','t',#000,
+  'F','_','M','a','c','r','o',' ','b','u','f','f','e','r',' ',
+  'o','v','e','r','f','l','o','w',' ','w','h','i','l','e',' ',
+  'r','e','a','d','i','n','g',' ','o','r',' ','e','x','p','a',
+  'n','d','i','n','g',' ','a',' ','m','a','c','r','o',#000,'W',
+  '_','E','x','t','e','n','s','i','o','n',' ','o','f',' ','m',
+  'a','c','r','o','s',' ','e','x','c','e','e','d','s',' ','a',
+  ' ','d','e','e','p',' ','o','f',' ','1','6',',',' ','p','e',
+  'r','h','a','p','s',' ','t','h','e','r','e',' ','i','s',' ',
+  'a',' ','r','e','c','u','r','s','i','v','e',' ','m','a','c',
+  'r','o',' ','d','e','f','i','n','i','t','i','o','n',' ','(',
+  'c','r','a','s','h','e','s',' ','t','h','e',' ','c','o','m',
+  'p','i','l','e','r',')',#000,'E','_','c','o','m','p','i','l',
+  'e','r',' ','s','w','i','t','c','h','e','s',' ','a','r','e',
+  'n',#039,'t',' ','a','l','l','o','w','e','d',' ','i','n',' ',
+  '(','*',' ','.','.','.',' ','*',')',' ','s','t','y','l','e',
+  'd',' ','c','o','m','m','e','n','t','s',#000,'D','_','H','a',
+  'n','d','l','i','n','g',' ','s','w','i','t','c','h',' ','"',
+  '$','1','"',#000,'C','_','E','N','D','I','F',' ','$','1',' ',
+  'f','o','u','n','d',#000,'C','_','I','F','D','E','F',' ','$',
+  '1',' ','f','o','u','n','d',',',' ','$','2',#000,'C','_','I',
+  'F','O','P','T',' ','$','1',' ','f','o','u','n','d',',',' ',
+  '$','2',#000,'C','_','I','F',' ','$','1',' ','f','o','u','n',
+  'd',',',' ','$','2',#000,'C','_','I','F','N','D','E','F',' ',
+  '$','1',' ','f','o','u','n','d',',',' ','$','2',#000,'C','_',
+  'E','L','S','E',' ','$','1',' ','f','o','u','n','d',',',' ',
+  '$','2',#000,'C','_','S','k','i','p','p','i','n','g',' ','u',
+  'n','t','i','l','.','.','.',#000,'I','_','P','r','e','s','s',
+  ' ','<','r','e','t','u','r','n','>',' ','t','o',' ','c','o',
+  'n','t','i','n','u','e',#000,'E','_','P','a','r','s','e','r',
+  ' ','-',' ','S','y','n','t','a','x',' ','E','r','r','o','r',
+  #000,'W','_','P','r','o','c','e','d','u','r','e',' ','t','y',
+  'p','e',' ','F','A','R',' ','i','g','n','o','r','e','d',#000,
+  'W','_','P','r','o','c','e','d','u','r','e',' ','t','y','p',
+  'e',' ','N','E','A','R',' ','i','g','n','o','r','e','d',#000,
+  'E','_','N','o',' ','D','L','L',' ','F','i','l','e',' ','s',
+  'p','e','c','i','f','i','e','d',#000,'E','_','C','o','n','s',
+  't','r','u','c','t','o','r',' ','n','a','m','e',' ','m','u',
+  's','t',' ','b','e',' ','I','N','I','T',#000,'E','_','D','e',
+  's','t','r','u','c','t','o','r',' ','n','a','m','e',' ','m',
+  'u','s','t',' ','b','e',' ','D','O','N','E',#000,'E','_','I',
+  'l','l','e','g','a','l',' ','o','p','e','n',' ','p','a','r',
+  'a','m','e','t','e','r',#000,'E','_','P','r','o','c','e','d',
+  'u','r','e',' ','t','y','p','e',' ','I','N','L','I','N','E',
+  ' ','n','o','t',' ','s','u','p','p','o','r','t','e','d',#000,
+  'W','_','P','r','i','v','a','t','e',' ','m','e','t','h','o',
+  'd','s',' ','s','h','o','u','l','d','n',#039,'t',' ','b','e',
+  ' ','V','I','R','T','U','A','L',#000,'E','_','C','o','n','s',
+  't','r','u','c','t','o','r',' ','c','a','n',#039,'t',' ','b',
+  'e',' ','p','r','i','v','a','t','e',' ','o','r',' ','p','r',
+  'o','t','e','c','t','e','d',#000,'E','_','D','e','s','t','r',
+  'u','c','t','o','r',' ','c','a','n',#039,'t',' ','b','e',' ',
+  'p','r','i','v','a','t','e',' ','o','r',' ','p','r','o','t',
+  'e','c','t','e','d',#000,'N','_','C','l','a','s','s',' ','s',
+  'h','o','u','l','d',' ','h','a','v','e',' ','o','n','e',' ',
+  'd','e','s','t','r','u','c','t','o','r',' ','o','n','l','y',
+  #000,'E','_','L','o','c','a','l',' ','c','l','a','s','s',' ',
+  'd','e','f','i','n','i','t','i','o','n','s',' ','a','r','e',
+  ' ','n','o','t',' ','a','l','l','o','w','e','d',#000,'E','_',
+  'A','n','o','n','y','m',' ','c','l','a','s','s',' ','d','e',
+  'f','i','n','i','t','i','o','n','s',' ','a','r','e',' ','n',
+  'o','t',' ','a','l','l','o','w','e','d',#000,'E','_','O','r',
+  'd','i','n','a','l',' ','v','a','l','u','e',' ','e','x','p',
+  'e','c','t','e','d',#000,'E','_','I','l','l','e','g','a','l',
+  ' ','p','a','r','a','m','e','t','e','r',' ','l','i','s','t',
+  #000,'E','_','o','v','e','r','l','o','a','d','e','d',' ','i',
+  'd','e','n','t','i','f','i','e','r',' ','i','s','n',#039,'t',
+  ' ','a',' ','f','u','n','c','t','i','o','n',' ','i','d','e',
+  'n','t','i','f','i','e','r',#000,'E','_','o','v','e','r','l',
+  'o','a','d','e','d',' ','f','u','n','c','t','i','o','n','s',
+  ' ','h','a','v','e',' ','t','h','e',' ','s','a','m','e',' ',
+  'p','a','r','a','m','e','t','e','r',' ','l','i','s','t',#000,
+  'E','_','f','u','n','c','t','i','o','n',' ','h','e','a','d',
+  'e','r',' ','d','o','e','s','n',#039,'t',' ','m','a','t','c',
+  'h',' ','t','h','e',' ','f','o','r','w','a','r','d',' ','d',
+  'e','c','l','a','r','a','t','i','o','n',' ','$','1',#000,'N',
+  '_','o','n','l','y',' ','v','a','l','u','e','s',' ','c','a',
+  'n',' ','b','e',' ','j','u','m','p','e','d',' ','o','v','e',
+  'r',' ','i','n',' ','e','n','u','m','e','r','a','t','i','o',
+  'n',' ','t','y','p','e','s',#000,'N','_','I','n','t','e','r',
+  'f','a','c','e',' ','a','n','d',' ','i','m','p','l','e','m',
+  'e','n','t','a','t','i','o','n',' ','n','a','m','e','s',' ',
+  'a','r','e',' ','d','i','f','f','e','r','e','n','t',' ','!',
+  #000,'E','_','f','u','n','c','t','i','o','n',' ','n','e','s',
+  't','i','n','g',' ','>',' ','3','1',#000,'E','_','r','a','n',
+  'g','e',' ','c','h','e','c','k',' ','e','r','r','o','r',' ',
+  'w','h','i','l','e',' ','e','v','a','l','u','a','t','i','n',
+  'g',' ','c','o','n','s','t','a','n','t','s',#000,'E','_','p',
+  'o','i','n','t','e','r',' ','t','y','p','e',' ','e','x','p',
+  'e','c','t','e','d',#000,'E','_','c','l','a','s','s',' ','t',
+  'y','p','e',' ','e','x','p','e','c','t','e','d',#000,'E','_',
+  'd','u','p','l','i','c','a','t','e',' ','c','a','s','e',' ',
+  'l','a','b','e','l',#000,'E','_','t','y','p','e','d',' ','c',
+  'o','n','s','t','a','n','t','s',' ','o','f',' ','c','l','a',
+  's','s','e','s',' ','a','r','e',' ','n','o','t',' ','a','l',
+  'l','o','w','e','d',#000,'E','_','f','u','n','c','t','i','o',
+  'n','s',' ','v','a','r','i','a','b','l','e','s',' ','o','f',
+  ' ','o','v','e','r','l','o','a','d','e','d',' ','f','u','n',
+  'c','t','i','o','n','s',' ','a','r','e',' ','n','o','t',' ',
+  'a','l','l','o','w','e','d',#000,'E','_','s','t','r','i','n',
+  'g',' ','l','e','n','g','t','h',' ','m','u','s','t',' ','b',
+  'e',' ','a',' ','v','a','l','u','e',' ','f','r','o','m',' ',
+  '1',' ','t','o',' ','2','5','5',#000,'W','_','u','s','e',' ',
+  'e','x','t','e','n','d','e','d',' ','s','y','n','t','a','x',
+  ' ','o','f',' ','D','I','S','P','O','S','E',' ','a','n','d',
+  ' ','N','E','W',' ','t','o',' ','g','e','n','e','r','a','t',
+  'e',' ','i','n','s','t','a','n','c','e','s',' ','o','f',' ',
+  'c','l','a','s','s','e','s',#000,'E','_','c','l','a','s','s',
+  ' ','i','d','e','n','t','i','f','i','e','r',' ','e','x','p',
+  'e','c','t','e','d',#000,'E','_','m','e','t','h','o','d',' ',
+  'i','d','e','n','t','i','f','i','e','r',' ','e','x','p','e',
+  'c','t','e','d',#000,'E','_','f','u','n','c','t','i','o','n',
+  ' ','h','e','a','d','e','r',' ','d','o','e','s','n',#039,'t',
+  ' ','m','a','t','c','h',' ','a','n','y',' ','m','e','t','h',
+  'o','d',' ','o','f',' ','t','h','i','s',' ','c','l','a','s',
+  's',#000,'P','_','p','r','o','c','e','d','u','r','e','/','f',
+  'u','n','c','t','i','o','n',' ','$','1',' ','(','$','2',')',
+  ' ','a','t',' ','l','i','n','e',' ','$','3',#000,'E','_','I',
+  'l','l','e','g','a','l',' ','f','l','o','a','t','i','n','g',
+  ' ','p','o','i','n','t',' ','c','o','n','s','t','a','n','t',
+  #000,'E','_','F','A','I','L',' ','c','a','n',' ','b','e',' ',
+  'u','s','e','d',' ','i','n',' ','c','o','n','s','t','r','u',
+  'c','t','o','r','s',' ','o','n','l','y',#000,'E','_','D','e',
+  's','t','r','u','c','t','o','r','s',' ','c','a','n',#039,'t',
+  ' ','h','a','v','e',' ','p','a','r','a','m','e','t','e','r',
+  's',#000,'E','_','s','t','r','i','n','g',' ','t','y','p','e',
+  's',' ','d','o','e','s','n',#039,'t',' ','m','a','t','c','h',
+  ',',' ','b','e','c','a','u','s','e',' ','o','f',' ','$','V',
+  '+',' ','m','o','d','e',#000,'E','_','O','n','l','y',' ','c',
+  'l','a','s','s',' ','m','e','t','h','o','d','s',' ','c','a',
+  'n',' ','b','e',' ','r','e','f','e','r','r','e','d',' ','w',
+  'i','t','h',' ','c','l','a','s','s',' ','r','e','f','e','r',
+  'e','n','c','e','s',#000,'E','_','O','n','l','y',' ','c','l',
+  'a','s','s',' ','m','e','t','h','o','d','s',' ','c','a','n',
+  ' ','b','e',' ','a','c','c','e','s','s','e','d',' ','i','n',
+  ' ','c','l','a','s','s',' ','m','e','t','h','o','d','s',#000,
+  'E','_','C','o','n','s','t','a','n','t',' ','a','n','d',' ',
+  'C','A','S','E',' ','t','y','p','e','s',' ','d','o',' ','n',
+  'o','t',' ','m','a','t','c','h',#000,'E','_','T','h','e',' ',
+  's','y','m','b','o','l',' ','c','a','n',#039,'t',' ','b','e',
+  ' ','e','x','p','o','r','t','e','d',' ','f','r','o','m',' ',
+  'a',' ','l','i','b','r','a','r','y',#000,'E','_','A',' ','v',
+  'i','r','t','u','a','l',' ','m','e','t','h','o','d',' ','m',
+  'u','s','t',' ','b','e',' ','o','v','e','r','r','i','d','d',
+  'e','n',' ','u','s','i','n','g',' ','t','h','e',' ','O','V',
+  'E','R','R','I','D','E',' ','d','i','r','e','c','t','i','v',
+  'e',':',' ','$','1',#000,'E','_','T','h','e','r','e',' ','i',
+  's',' ','n','o',' ','m','e','t','h','o','d',' ','i','n',' ',
+  'a','n',' ','a','n','c','e','s','t','o','r',' ','c','l','a',
+  's','s',' ','t','o',' ','b','e',' ','o','v','e','r','r','i',
+  'd','d','e','n',':',' ','$','1',#000,'E','_','N','o',' ','m',
+  'e','m','b','e','r',' ','i','s',' ','p','r','o','v','i','d',
+  'e','d',' ','t','o',' ','a','c','c','e','s','s',' ','p','r',
+  'o','p','e','r','t','y',#000,'E','_','I','l','l','e','g','a',
+  'l',' ','s','y','m','b','o','l',' ','f','o','r',' ','p','r',
+  'o','p','e','r','t','y',' ','a','c','c','e','s','s',#000,'E',
+  '_','C','a','n','n','o','t',' ','w','r','i','t','e',' ','a',
+  ' ','p','r','o','t','e','c','t','e','d',' ','f','i','e','l',
+  'd',' ','o','f',' ','a','n',' ','o','b','j','e','c','t',#000,
+  'E','_','a','l','l',' ','o','v','e','r','l','o','a','d','e',
+  'd',' ','m','e','t','h','o','d','s',' ','m','u','s','t',' ',
+  'b','e',' ','v','i','r','t','u','a','l',' ','i','f',' ','o',
+  'n','e',' ','i','s',' ','v','i','r','t','u','a','l',':',' ',
+  '$','1',#000,'E','_','o','v','e','r','l','o','a','d','e','d',
+  ' ','m','e','t','h','o','d','s',' ','w','h','i','c','h',' ',
+  'a','r','e',' ','v','i','r','t','u','a','l',' ','m','u','s',
+  't',' ','h','a','v','e',' ','t','h','e',' ','s','a','m','e',
+  ' ','r','e','t','u','r','n',' ','t','y','p','e',':',' ','$',
+  '1',#000,'E','_','E','X','P','O','R','T',' ','d','e','c','l',
+  'a','r','e','d',' ','f','u','n','c','t','i','o','n','s',' ',
+  'c','a','n',#039,'t',' ','b','e',' ','n','e','s','t','e','d',
+  #000,'E','_','m','e','t','h','o','d','s',' ','c','a','n',#039,
+  't',' ','b','e',' ','E','X','P','O','R','T','e','d',#000,'E',
+  '_','c','a','l','l',' ','b','y',' ','v','a','r',' ','p','a',
+  'r','a','m','e','t','e','r','s',' ','h','a','v','e',' ','t',
+  'o',' ','m','a','t','c','h',' ','e','x','a','c','t','l','y',
+  #000,'E','_','C','l','a','s','s',' ','i','s','n',#039,'t',' ',
+  'a',' ','s','u','p','e','r',' ','c','l','a','s','s',' ','o',
+  'f',' ','t','h','e',' ','c','u','r','r','e','n','t',' ','c',
+  'l','a','s','s',#000,'E','_','S','E','L','F',' ','i','s',' ',
+  'o','n','l','y',' ','a','l','l','o','w','e','d',' ','i','n',
+  ' ','m','e','t','h','o','d','s',#000,'E','_','m','e','t','h',
+  'o','d','s',' ','c','a','n',' ','b','e',' ','o','n','l','y',
+  ' ','i','n',' ','o','t','h','e','r',' ','m','e','t','h','o',
+  'd','s',' ','c','a','l','l','e','d',' ','d','i','r','e','c',
+  't',' ','w','i','t','h',' ','t','y','p','e',' ','i','d','e',
+  'n','t','i','f','i','e','r',' ','o','f',' ','t','h','e',' ',
+  'c','l','a','s','s',#000,'E','_','I','l','l','e','g','a','l',
+  ' ','u','s','e',' ','o','f',' ',#039,':',#039,#000,'E','_','r',
+  'a','n','g','e',' ','c','h','e','c','k',' ','e','r','r','o',
+  'r',' ','i','n',' ','s','e','t',' ','c','o','n','s','t','r',
+  'u','c','t','o','r',' ','o','r',' ','d','u','p','l','i','c',
+  'a','t','e',' ','s','e','t',' ','e','l','e','m','e','n','t',
+  #000,'E','_','P','o','i','n','t','e','r',' ','t','o',' ','c',
+  'l','a','s','s',' ','e','x','p','e','c','t','e','d',#000,'E',
+  '_','E','x','p','r','e','s','s','i','o','n',' ','m','u','s',
+  't',' ','b','e',' ','c','o','n','s','t','r','u','c','t','o',
+  'r',' ','c','a','l','l',#000,'E','_','E','x','p','r','e','s',
+  's','i','o','n',' ','m','u','s','t',' ','b','e',' ','d','e',
+  's','t','r','u','c','t','o','r',' ','c','a','l','l',#000,'E',
+  '_','T','y','p','e',' ','c','o','n','f','l','i','c','t',' ',
+  'b','e','t','w','e','e','n',' ','s','e','t',' ','e','l','e',
+  'm','e','n','t','s',#000,'W','_','T','h','e',' ','o','p','e',
+  'r','a','t','o','r',' ','/',' ','i','s','n',#039,'t',' ','d',
+  'e','f','i','n','e','d',' ','f','o','r',' ','i','n','t','e',
+  'g','e','r',',',' ','t','h','e',' ','r','e','s','u','l','t',
+  ' ','w','i','l','l',' ','b','e',' ','r','e','a','l',',',' ',
+  'u','s','e',' ','D','I','V',' ','i','n','s','t','e','a','d',
+  #000,'E','_','I','l','l','e','g','a','l',' ','o','r','d','e',
+  'r',' ','o','f',' ','r','e','c','o','r','d',' ','e','l','e',
+  'm','e','n','t','s',#000,'E','_','E','x','p','r','e','s','s',
+  'i','o','n',' ','t','y','p','e',' ','m','u','s','t',' ','b',
+  'y',' ','c','l','a','s','s',' ','o','r',' ','r','e','c','o',
+  'r','d',' ','t','y','p','e',#000,'E','_','F','u','n','c','t',
+  'i','o','n','s',' ','w','i','t','h',' ','v','o','i','d',' ',
+  'r','e','t','u','r','n',' ','v','a','l','u','e',' ','c','a',
+  'n',#039,'t',' ','r','e','t','u','r','n',' ','a','n','y',' ',
+  'v','a','l','u','e',#000,'E','_','c','o','n','s','t','r','u',
+  'c','t','o','r','s',' ','a','n','d',' ','d','e','s','t','r',
+  'u','c','t','o','r','s',' ','m','u','s','t',' ','b','e',' ',
+  'm','e','t','h','o','d','s',#000,'W','_','A','u','t','o','m',
+  'a','t','i','c',' ','t','y','p','e',' ','c','o','n','v','e',
+  'r','s','i','o','n',' ','f','r','o','m',' ','f','l','o','a',
+  't','i','n','g',' ','t','y','p','e',' ','t','o',' ','C','O',
+  'M','P',' ','w','h','i','c','h',' ','i','s',' ','a','n',' ',
+  'i','n','t','e','g','e','r',' ','t','y','p','e',#000,'E','_',
+  'O','p','e','r','a','t','o','r',' ','i','s',' ','n','o','t',
+  ' ','o','v','e','r','l','o','a','d','e','d',#000,'E','_','V',
+  'a','r','i','a','b','l','e',' ','o','r',' ','t','y','p','e',
+  ' ','i','n','d','e','n','t','i','f','i','e','r',' ','e','x',
+  'p','e','c','t','e','d',#000,'E','_','R','e','-','r','a','i',
+  's','e',' ','i','s','n',#039,'t',' ','p','o','s','s','i','b',
+  'l','e',' ','t','h','e','r','e',#000,'E','_','T','h','e',' ',
+  'e','x','t','e','n','d','e','d',' ','s','y','n','t','a','x',
+  ' ','o','f',' ','n','e','w',' ','o','r',' ','d','i','s','p',
+  'o','s','e',' ','i','s','n',#039,'t',' ','a','l','l','o','w',
+  'e','d',' ','f','o','r',' ','a',' ','c','l','a','s','s',#000,
+  'E','_','A','s','s','e','m','b','l','e','r',' ','i','n','c',
+  'o','m','p','a','t','i','b','l','e',' ','w','i','t','h',' ',
+  'f','u','n','c','t','i','o','n',' ','r','e','t','u','r','n',
+  ' ','v','a','l','u','e',#000,'E','_','P','r','o','c','e','d',
+  'u','r','e',' ','o','v','e','r','l','o','a','d','i','n','g',
+  ' ','i','s',' ','s','w','i','t','c','h','e','d',' ','o','f',
+  'f',#000,'E','_','I','t',' ','i','s',' ','n','o','t',' ','p',
+  'o','s','s','i','b','l','e',' ','t','o',' ','o','v','e','r',
+  'l','o','a','d',' ','t','h','i','s',' ','o','p','e','r','a',
+  't','o','r',' ','(','o','v','e','r','l','o','a','d',' ','=',
+  ' ','i','n','s','t','e','a','d',')',#000,'E','_','C','o','m',
+  'p','a','r','a','t','i','v','e',' ','o','p','e','r','a','t',
+  'o','r',' ','m','u','s','t',' ','r','e','t','u','r','n',' ',
+  'a',' ','b','o','o','l','e','a','n',' ','v','a','l','u','e',
+  #000,'E','_','O','n','l','y',' ','v','i','r','t','u','a','l',
+  ' ','m','e','t','h','o','d','s',' ','c','a','n',' ','b','e',
+  ' ','a','b','s','t','r','a','c','t',#000,'F','_','U','s','e',
+  ' ','o','f',' ','u','n','s','u','p','p','o','r','t','e','d',
+  ' ','f','e','a','t','u','r','e','!',#000,'E','_','T','h','e',
+  ' ','m','i','x',' ','o','f',' ','C','L','A','S','S','E','S',
+  ' ','a','n','d',' ','O','B','J','E','C','T','S',' ','i','s',
+  'n',#039,'t',' ','a','l','l','o','w','e','d',#000,'W','_','U',
+  'n','k','n','o','w','n',' ','p','r','o','c','e','d','u','r',
+  'e',' ','d','i','r','e','c','t','i','v','e',' ','h','a','d',
+  ' ','t','o',' ','b','e',' ','i','g','n','o','r','e','d',':',
+  ' ','$','1',#000,'E','_','a','b','s','o','l','u','t','e',' ',
+  'c','a','n',' ','o','n','l','y',' ','b','e',' ','a','s','s',
+  'o','c','i','a','t','e','d',' ','t','o',' ','O','N','E',' ',
+  'v','a','r','i','a','b','l','e',#000,'E','_','a','b','s','o',
+  'l','u','t','e',' ','c','a','n',' ','o','n','l','y',' ','b',
+  'e',' ','a','s','s','o','c','i','a','t','e','d',' ','a',' ',
+  'v','a','r',' ','o','r',' ','c','o','n','s','t',#000,'E','_',
+  'A','b','t','r','a','c','t',' ','m','e','t','h','o','d','s',
+  ' ','s','h','o','u','l','d','n',#039,'t',' ','h','a','v','e',
+  ' ','a','n','y',' ','d','e','f','i','n','i','t','i','o','n',
+  ' ','(','w','i','t','h',' ','f','u','n','c','t','i','o','n',
+  ' ','b','o','d','y',')',#000,'E','_','T','h','i','s',' ','o',
+  'v','e','r','l','o','a','d','e','d',' ','f','u','n','c','t',
+  'i','o','n',' ','c','a','n',#039,'t',' ','b','e',' ','l','o',
+  'c','a','l',' ','(','m','u','s','t',' ','b','e',' ','e','x',
+  'p','o','r','t','e','d',')',#000,'E','_','s','u','c','c',' ',
+  'o','r',' ','p','r','e','d',' ','o','n',' ','e','n','u','m',
+  's',' ','w','i','t','h',' ','a','s','s','i','g','n','m','e',
+  'n','t','s',' ','n','o','t',' ','p','o','s','s','i','b','l',
+  'e',#000,'W','_','V','i','r','t','u','a','l',' ','m','e','t',
+  'h','o','d','s',' ','a','r','e',' ','u','s','e','d',' ','w',
+  'i','t','h','o','u','t',' ','a',' ','c','o','n','s','t','r',
+  'u','c','t','o','r',#000,'M','_','M','a','c','r','o',' ','d',
+  'e','f','i','n','e','d',':',' ','$','1',#000,'M','_','M','a',
+  'c','r','o',' ','u','n','d','e','f','i','n','e','d',':',' ',
+  '$','1',#000,'M','_','M','a','c','r','o',' ','$','1',' ','s',
+  'e','t',' ','t','o',' ','$','2',#000,'I','_','C','o','m','p',
+  'i','l','i','n','g',' ','$','1',#000,'D','_','C','o','m','p',
+  'i','l','i','n','g',' ','$','1',' ','f','o','r',' ','t','h',
+  'e',' ','s','e','c','o','n','d',' ','t','i','m','e',#000,'E',
+  '_','A','r','r','a','y',' ','p','r','o','p','e','r','t','i',
+  'e','s',' ','a','r','e','n',#039,'t',' ','a','l','l','o','w',
+  'e','d',' ','a','t',' ','t','h','i','s',' ','p','o','i','n',
+  't',#000,'E','_','N','o',' ','p','r','o','p','e','r','t','y',
+  ' ','f','o','u','n','d',' ','t','o',' ','o','v','e','r','r',
+  'i','d','e',#000,'E','_','O','n','l','y',' ','o','n','e',' ',
+  'd','e','f','a','u','l','t',' ','p','r','o','p','e','r','t',
+  'y',' ','i','s',' ','a','l','l','o','w','e','d',',',' ','f',
+  'o','u','n','d',' ','i','n','h','e','r','i','t','e','d',' ',
+  'd','e','f','a','u','l','t',' ','p','r','o','p','e','r','t',
+  'y',' ','i','n',' ','c','l','a','s','s',' ','%','1',#000,'E',
+  '_','T','h','e',' ','d','e','f','a','u','l','t',' ','p','r',
+  'o','p','e','r','t','y',' ','m','u','s','t',' ','b','e',' ',
+  'a','n',' ','a','r','r','a','y',' ','p','r','o','p','e','r',
+  't','y',#000,'N','_','L','o','c','a','l',' ','v','a','r','i',
+  'a','b','l','e',' ','$','1',' ','d','o','e','s','n',#039,'t',
+  ' ','s','e','e','m',' ','t','o',' ','b','e',' ','i','n','i',
+  't','i','a','l','i','z','e','d',' ','y','e','t',' ','!',#000,
+  'E','_','I','d','e','n','t','i','f','i','e','r',' ','n','o',
+  't',' ','f','o','u','n','d',' ','$','1',#000,'F','_','I','n',
+  't','e','r','n','a','l',' ','E','r','r','o','r',' ','i','n',
+  ' ','S','y','m','T','a','b','l','e','S','t','a','c','k','(',
+  ')',#000,'E','_','D','u','p','l','i','c','a','t','e',' ','i',
+  'd','e','n','t','i','f','i','e','r',' ','$','1',#000,'E','_',
+  'U','n','k','n','o','w','n',' ','i','d','e','n','t','i','f',
+  'i','e','r',' ','$','1',#000,'E','_','F','o','r','w','a','r',
+  'd',' ','d','e','c','l','a','r','a','t','i','o','n',' ','n',
+  'o','t',' ','s','o','l','v','e','d',' ','$','1',#000,'F','_',
+  'I','d','e','n','t','i','f','i','e','r',' ','t','y','p','e',
+  ' ','a','l','r','e','a','d','y',' ','d','e','f','i','n','e',
+  'd',' ','a','s',' ','t','y','p','e',#000,'E','_','T','y','p',
+  'e',' ','i','d','e','n','t','i','f','i','e','r',' ','e','x',
+  'p','e','c','t','e','d',#000,'E','_','T','y','p','e',' ','m',
+  'i','s','m','a','t','c','h',#000,'E','_','E','r','r','o','r',
+  ' ','i','n',' ','t','y','p','e',' ','d','e','f','e','n','i',
+  't','i','o','n',#000,'E','_','T','y','p','e',' ','i','d','e',
+  'n','t','i','f','i','e','r',' ','n','o','t',' ','d','e','f',
+  'i','n','e','d',#000,'E','_','O','n','l','y',' ','s','t','a',
+  't','i','c',' ','v','a','r','i','a','b','l','e','s',' ','c',
+  'a','n',' ','b','e',' ','u','s','e','d',' ','i','n',' ','s',
+  't','a','t','i','c',' ','m','e','t','h','o','d','s',' ','o',
+  'r',' ','o','u','t','s','i','d','e',' ','m','e','t','h','o',
+  'd','s',#000,'E','_','I','n','v','a','l','i','d',' ','c','a',
+  'l','l',' ','t','o',' ','t','v','a','r','s','y','m','.','m',
+  'a','n','g','l','e','d','n','a','m','e','(',')',#000,'F','_',
+  'r','e','c','o','r','d',' ','o','r',' ','c','l','a','s','s',
+  ' ','t','y','p','e',' ','e','x','p','e','c','t','e','d',#000,
+  'E','_','T','o',' ','g','e','n','e','r','a','t','e',' ','a',
+  'n',' ','i','n','s','t','a','n','c','e',' ','o','f',' ','a',
+  ' ','c','l','a','s','s',' ','o','r',' ','a','n',' ','o','b',
+  'j','e','c','t',' ','w','i','t','h',' ','a','n',' ','a','b',
+  't','r','a','c','t',' ','m','e','t','h','o','d',' ','i','s',
+  'n',#039,'t',' ','a','l','l','o','w','e','d',#000,'E','_','L',
+  'a','b','e','l',' ','n','o','t',' ','d','e','f','i','n','e',
+  'd',' ','$','1',#000,'E','_','I','l','l','e','g','a','l',' ',
+  'l','a','b','e','l',' ','d','e','c','l','a','r','a','t','i',
+  'o','n',#000,'E','_','G','O','T','O',' ','u','n','d',' ','L',
+  'A','B','E','L',' ','a','r','e',' ','n','o','t',' ','s','u',
+  'p','p','o','r','t','e','d',' ','(','u','s','e',' ','c','o',
+  'm','m','a','n','d',' ','l','i','n','e',' ','s','w','i','t',
+  'c','h',' ','-','S','g',')',#000,'E','_','L','a','b','e','l',
+  ' ','n','o','t',' ','f','o','u','n','d',#000,'E','_','i','d',
+  'e','n','t','i','f','i','e','r',' ','i','s','n',#039,'t',' ',
+  'a',' ','l','a','b','e','l',#000,'E','_','l','a','b','e','l',
+  ' ','a','l','r','e','a','d','y',' ','d','e','f','i','n','e',
+  'd',#000,'E','_','i','l','l','e','g','a','l',' ','t','y','p',
+  'e',' ','d','e','c','l','a','r','a','t','i','o','n',' ','o',
+  'f',' ','s','e','t',' ','e','l','e','m','e','n','t','s',#000,
+  'E','_','F','o','r','w','a','r','d',' ','c','l','a','s','s',
+  ' ','d','e','f','i','n','i','t','i','o','n',' ','n','o','t',
+  ' ','r','e','s','o','l','v','e','d',' ','$','1',#000,'H','_',
+  'I','d','e','n','t','i','f','i','e','r',' ','n','o','t',' ',
+  'u','s','e','d',' ','$','1',',',' ','d','e','c','l','a','r',
+  'e','d',' ','i','n',' ','l','i','n','e',' ','$','2',#000,'E',
+  '_','S','e','t',' ','e','l','e','m','e','n','t','s',' ','a',
+  'r','e',' ','n','o','t',' ','c','o','m','p','a','t','i','b',
+  'l','e',#000,'E','_','S','e','t',' ','t','y','p','e',' ','e',
+  'x','p','e','c','t','e','d',#000,'W','_','F','u','n','c','t',
+  'i','o','n',' ','r','e','s','u','l','t',' ','d','o','e','s',
+  ' ','n','o','t',' ','s','e','e','m',' ','t','o',' ','b','e',
+  ' ','s','e','t',#000,'E','_','U','n','k','n','o','w','n',' ',
+  'f','i','e','l','d',' ','i','d','e','n','t','i','f','i','e',
+  'r',#000,'N','_','L','o','c','a','l',' ','v','a','r','i','a',
+  'b','l','e',' ','d','o','e','s',' ','n','o','t',' ','s','e',
+  'e','m',' ','t','o',' ','b','e',' ','i','n','i','t','i','a',
+  'l','i','z','e','d',':',' ','$','1',#000,'E','_','i','d','e',
+  'n','t','i','f','i','e','r',' ','i','d','e','n','t','s',' ',
+  'n','o',' ','m','e','m','b','e','r',#000,'E','_','B','R','E',
+  'A','K',' ','n','o','t',' ','a','l','l','o','w','e','d',#000,
+  'E','_','C','O','N','T','I','N','U','E',' ','n','o','t',' ',
+  'a','l','l','o','w','e','d',#000,'E','_','E','x','p','r','e',
+  's','s','i','o','n',' ','t','o','o',' ','c','o','m','p','l',
+  'i','c','a','t','e','d',' ','-',' ','F','P','U',' ','s','t',
+  'a','c','k',' ','o','v','e','r','f','l','o','w',#000,'E','_',
+  'I','l','l','e','g','a','l',' ','e','x','p','r','e','s','s',
+  'i','o','n',#000,'E','_','I','n','v','a','l','i','d',' ','i',
+  'n','t','e','g','e','r',#000,'E','_','I','l','l','e','g','a',
+  'l',' ','q','u','a','l','i','f','i','e','r',#000,'E','_','H',
+  'i','g','h',' ','r','a','n','g','e',' ','l','i','m','i','t',
+  ' ','<',' ','l','o','w',' ','r','a','n','g','e',' ','l','i',
+  'm','i','t',#000,'E','_','I','l','l','e','g','a','l',' ','c',
+  'o','u','n','t','e','r',' ','v','a','r','i','a','b','l','e',
+  #000,'E','_','C','a','n',#039,'t',' ','d','e','t','e','r','m',
+  'i','n','e',' ','w','h','i','c','h',' ','o','v','e','r','l',
+  'o','a','d','e','d',' ','f','u','n','c','t','i','o','n',' ',
+  't','o',' ','c','a','l','l',#000,'E','_','P','a','r','a','m',
+  'e','t','e','r',' ','l','i','s','t',' ','s','i','z','e',' ',
+  'e','x','c','e','e','d','s',' ','6','5','5','3','5',' ','b',
+  'y','t','e','s',#000,'E','_','I','l','l','e','g','a','l',' ',
+  't','y','p','e',' ','c','o','n','v','e','r','s','i','o','n',
+  #000,'E','_','F','i','l','e',' ','t','y','p','e','s',' ','m',
+  'u','s','t',' ','b','e',' ','v','a','r',' ','p','a','r','a',
+  'm','e','t','e','r','s',#000,'E','_','T','h','e',' ','u','s',
+  'e',' ','o','f',' ','a',' ','f','a','r',' ','p','o','i','n',
+  't','e','r',' ','i','s','n',#039,'t',' ','a','l','l','o','w',
+  'e','d',' ','t','h','e','r','e',#000,'E','_','i','l','l','e',
+  'g','a','l',' ','c','a','l','l',' ','b','y',' ','r','e','f',
+  'e','r','e','n','c','e',' ','p','a','r','a','m','e','t','e',
+  'r','s',#000,'E','_','E','X','P','O','R','T',' ','d','e','c',
+  'l','a','r','e','d',' ','f','u','n','c','t','i','o','n','s',
+  ' ','c','a','n',#039,'t',' ','b','e',' ','c','a','l','l','e',
+  'd',#000,'W','_','P','o','s','s','i','b','l','e',' ','i','l',
+  'l','e','g','a','l',' ','c','a','l','l',' ','o','f',' ','c',
+  'o','n','s','t','r','u','c','t','o','r',' ','o','r',' ','d',
+  'e','s','t','r','u','c','t','o','r',' ','(','d','o','e','s',
+  'n',#039,'t',' ','m','a','t','c','h',' ','t','o',' ','t','h',
+  'i','s',' ','c','o','n','t','e','x','t',')',#000,'N','_','I',
+  'n','e','f','f','i','c','i','e','n','t',' ','c','o','d','e',
+  #000,'W','_','u','n','r','e','a','c','h','a','b','l','e',' ',
+  'c','o','d','e',#000,'E','_','p','r','o','c','e','d','u','r',
+  'e',' ','c','a','l','l',' ','w','i','t','h',' ','s','t','a',
+  'c','k','f','r','a','m','e',' ','E','S','P','/','S','P',#000,
+  'E','_','A','b','s','t','r','a','c','t',' ','m','e','t','h',
+  'o','d','s',' ','c','a','n',#039,'t',' ','b','e',' ','c','a',
+  'l','l','e','d',' ','d','i','r','e','c','t','l','y',#000,'F',
+  '_','I','n','t','e','r','n','a','l',' ','E','r','r','o','r',
+  ' ','i','n',' ','g','e','t','f','l','o','a','t','r','e','g',
+  '(',')',',',' ','a','l','l','o','c','a','t','i','o','n',' ',
+  'f','a','i','l','u','r','e',#000,'F','_','U','n','k','n','o',
+  'w','n',' ','f','l','o','a','t',' ','t','y','p','e',#000,'F',
+  '_','S','e','c','o','n','d','V','e','c','n','(',')',' ','b',
+  'a','s','e',' ','d','e','f','i','n','e','d',' ','t','w','i',
+  'c','e',#000,'F','_','E','x','t','e','n','d','e','d',' ','c',
+  'g','6','8','k',' ','n','o','t',' ','s','u','p','p','o','r',
+  't','e','d',#000,'F','_','3','2','-','b','i','t',' ','u','n',
+  's','i','g','n','e','d',' ','n','o','t',' ','s','u','p','p',
+  'o','r','t','e','d',' ','i','n',' ','M','C','6','8','0','0',
+  '0',' ','m','o','d','e',#000,'F','_','I','n','t','e','r','n',
+  'a','l',' ','E','r','r','o','r',' ','i','n',' ','s','e','c',
+  'o','n','d','i','n','l','i','n','e','(',')',#000,'D','_','R',
+  'e','g','i','s','t','e','r',' ','$','1',' ','w','e','i','g',
+  'h','t',' ','$','2',' ','$','3',#000,'E','_','S','t','a','c',
+  'k',' ','l','i','m','i','t',' ','e','x','c','e','d','e','e',
+  'd',' ','i','n',' ','l','o','c','a','l',' ','r','o','u','t',
+  'i','n','e',#000,'D','_','S','t','a','c','k',' ','f','r','a',
+  'm','e',' ','i','s',' ','o','m','i','t','e','d',#000,'F','_',
+  'D','i','v','i','d','e',' ','b','y',' ','z','e','r','o',' ',
+  'i','n',' ','a','s','m',' ','e','v','a','l','u','a','t','o',
+  'r',#000,'F','_','E','v','a','l','u','a','t','o','r',' ','s',
+  't','a','c','k',' ','o','v','e','r','f','l','o','w',#000,'F',
+  '_','E','v','a','l','u','a','t','o','r',' ','s','t','a','c',
+  'k',' ','u','n','d','e','r','f','l','o','w',#000,'F','_','I',
+  'n','v','a','l','i','d',' ','n','u','m','e','r','i','c',' ',
+  'f','o','r','m','a','t',' ','i','n',' ','a','s','m',' ','e',
+  'v','a','l','u','a','t','o','r',#000,'F','_','I','n','v','a',
+  'l','i','d',' ','O','p','e','r','a','t','o','r',' ','i','n',
+  ' ','a','s','m',' ','e','v','a','l','u','a','t','o','r',#000,
+  'F','_','U','n','k','n','o','w','n',' ','e','r','r','o','r',
+  ' ','i','n',' ','a','s','m',' ','e','v','a','l','u','a','t',
+  'o','r',#000,'W','_','I','n','v','a','l','i','d',' ','n','u',
+  'm','e','r','i','c',' ','v','a','l','u','e',#000,'E','_','e',
+  's','c','a','p','e',' ','s','e','q','u','e','n','c','e',' ',
+  'i','g','n','o','r','e','d',':',' ','$','1',#000,'E','_','A',
+  's','m',' ','s','y','n','t','a','x',' ','e','r','r','o','r',
+  ' ','-',' ','P','r','e','f','i','x',' ','n','o','t',' ','f',
+  'o','u','n','d',#000,'E','_','A','s','m',' ','s','y','n','t',
+  'a','x',' ','e','r','r','o','r',' ','-',' ','T','r','y','i',
+  'n','g',' ','t','o',' ','a','d','d',' ','m','o','r','e',' ',
+  't','h','a','n',' ','o','n','e',' ','p','r','e','f','i','x',
+  #000,'E','_','A','s','m',' ','s','y','n','t','a','x',' ','e',
+  'r','r','o','r',' ','-',' ','O','p','c','o','d','e',' ','n',
+  'o','t',' ','f','o','u','n','d',#000,'E','_','I','n','v','a',
+  'l','i','d',' ','s','y','m','b','o','l',' ','r','e','f','e',
+  'r','e','n','c','e',#000,'W','_','C','a','l','l','i','n','g',
+  ' ','a','n',' ','o','v','e','r','l','o','a','d',' ','f','u',
+  'n','c','t','i','o','n',' ','i','n',' ','a','n',' ','a','s',
+  'm',#000,'E','_','C','o','n','s','t','a','n','t',' ','v','a',
+  'l','u','e',' ','o','u','t',' ','o','f',' ','b','o','u','n',
+  'd','s',#000,'E','_','N','o','n','-','l','a','b','e','l',' ',
+  'p','a','t','t','e','r','n',' ','c','o','n','t','a','i','n',
+  's',' ','@',#000,'E','_','I','n','v','a','l','i','d',' ','O',
+  'p','e','r','a','n','d',':',' ','$','1',#000,'W','_','O','v',
+  'e','r','r','i','d','e',' ','o','p','e','r','a','t','o','r',
+  ' ','n','o','t',' ','s','u','p','p','o','r','t','e','d',#000,
+  'E','_','E','r','r','o','r',' ','i','n',' ','b','i','n','a',
+  'r','y',' ','c','o','n','s','t','a','n','t',':',' ','$','1',
+  #000,'E','_','E','r','r','o','r',' ','i','n',' ','o','c','t',
+  'a','l',' ','c','o','n','s','t','a','n','t',':',' ','$','1',
+  #000,'E','_','E','r','r','o','r',' ','i','n',' ','h','e','x',
+  'a','d','e','c','i','m','a','l',' ','c','o','n','s','t','a',
+  'n','t',':',' ','$','1',#000,'E','_','E','r','r','o','r',' ',
+  'i','n',' ','i','n','t','e','g','e','r',' ','c','o','n','s',
+  't','a','n','t',':',' ','$','1',#000,'E','_','I','n','v','a',
+  'l','i','d',' ','l','a','b','e','l','e','d',' ','o','p','c',
+  'o','d','e',#000,'F','_','I','n','t','e','r','n','a','l',' ',
+  'e','r','r','o','r',' ','i','n',' ','F','i','n','d','t','y',
+  'p','e','(',')',#000,'E','_','I','n','v','a','l','i','d',' ',
+  's','i','z','e',' ','f','o','r',' ','M','O','V','S','X','/',
+  'M','O','V','Z','X',#000,'E','_','1','6','-','b','i','t',' ',
+  'b','a','s','e',' ','i','n',' ','3','2','-','b','i','t',' ',
+  's','e','g','m','e','n','t',#000,'E','_','1','6','-','b','i',
+  't',' ','i','n','d','e','x',' ','i','n',' ','3','2','-','b',
+  'i','t',' ','s','e','g','m','e','n','t',#000,'E','_','I','n',
+  'v','a','l','i','d',' ','O','p','c','o','d','e',#000,'E','_',
+  'C','o','n','s','t','a','n','t',' ','r','e','f','e','r','e',
+  'n','c','e',' ','n','o','t',' ','a','l','l','o','w','e','d',
+  #000,'W','_','F','w','a','i','t',' ','c','a','n',' ','c','a',
+  'u','s','e',' ','e','m','u','l','a','t','i','o','n',' ','p',
+  'r','o','b','l','e','m','s',' ','w','i','t','h',' ','e','m',
+  'u','3','8','7',#000,'E','_','I','n','v','a','l','i','d',' ',
+  'c','o','m','b','i','n','a','t','i','o','n',' ','o','f',' ',
+  'o','p','c','o','d','e',' ','a','n','d',' ','o','p','e','r',
+  'a','n','d','s',#000,'W','_','O','p','c','o','d','e',' ','$',
+  '1',' ','n','o','t',' ','i','n',' ','t','a','b','l','e',',',
+  ' ','o','p','e','r','a','n','d','s',' ','n','o','t',' ','c',
+  'h','e','c','k','e','d',#000,'F','_','I','n','t','e','r','n',
+  'a','l',' ','E','r','r','o','r',' ','i','n',' ','C','o','n',
+  'c','a','t','O','p','c','o','d','e','(',')',#000,'E','_','I',
+  'n','v','a','l','i','d',' ','s','i','z','e',' ','i','n',' ',
+  'r','e','f','e','r','e','n','c','e',#000,'E','_','I','n','v',
+  'a','l','i','d',' ','m','i','d','d','l','e',' ','s','i','z',
+  'e','d',' ','o','p','e','r','a','n','d',#000,'E','_','I','n',
+  'v','a','l','i','d',' ','t','h','r','e','e',' ','o','p','e',
+  'r','a','n','d',' ','o','p','c','o','d','e',#000,'E','_','A',
+  's','s','e','m','b','l','e','r',' ','s','y','n','t','a','x',
+  ' ','e','r','r','o','r',#000,'E','_','I','n','v','a','l','i',
+  'd',' ','o','p','e','r','a','n','d',' ','t','y','p','e',#000,
+  'E','_','S','e','g','m','e','n','t',' ','o','v','e','r','r',
+  'i','d','e','s',' ','n','o','t',' ','s','u','p','p','o','r',
+  't','e','d',#000,'E','_','I','n','v','a','l','i','d',' ','c',
+  'o','n','s','t','a','n','t',' ','s','y','m','b','o','l',' ',
+  '$','1',#000,'F','_','I','n','t','e','r','n','a','l',' ','E',
+  'r','r','r','o','r',' ','c','o','n','v','e','r','t','i','n',
+  'g',' ','b','i','n','a','r','y',#000,'F','_','I','n','t','e',
+  'r','n','a','l',' ','E','r','r','r','o','r',' ','c','o','n',
+  'v','e','r','t','i','n','g',' ','h','e','x','a','d','e','c',
+  'i','m','a','l',#000,'F','_','I','n','t','e','r','n','a','l',
+  ' ','E','r','r','r','o','r',' ','c','o','n','v','e','r','t',
+  'i','n','g',' ','o','c','t','a','l',#000,'E','_','I','n','v',
+  'a','l','i','d',' ','c','o','n','s','t','a','n','t',' ','e',
+  'x','p','r','e','s','s','i','o','n',#000,'E','_','U','n','k',
+  'n','o','w','n',' ','i','d','e','n','t','i','f','i','e','r',
+  ':',' ','$','1',#000,'E','_','T','r','y','i','n','g',' ','t',
+  'o',' ','d','e','f','i','n','e',' ','a','n',' ','i','n','d',
+  'e','x',' ','r','e','g','i','s','t','e','r',' ','m','o','r',
+  'e',' ','t','h','a','n',' ','o','n','c','e',#000,'E','_','I',
+  'n','v','a','l','i','d',' ','f','i','e','l','d',' ','s','p',
+  'e','c','i','f','i','e','r',#000,'F','_','I','n','t','e','r',
+  'n','a','l',' ','E','r','r','o','r',' ','i','n',' ','B','u',
+  'i','l','d','S','c','a','l','i','n','g','(',')',#000,'E','_',
+  'I','n','v','a','l','i','d',' ','s','c','a','l','i','n','g',
+  ' ','f','a','c','t','o','r',#000,'E','_','I','n','v','a','l',
+  'i','d',' ','s','c','a','l','i','n','g',' ','v','a','l','u',
+  'e',#000,'E','_','S','c','a','l','i','n','g',' ','v','a','l',
+  'u','e',' ','o','n','l','y',' ','a','l','l','o','w','e','d',
+  ' ','w','i','t','h',' ','i','n','d','e','x',#000,'E','_','I',
+  'n','v','a','l','i','d',' ','a','s','s','e','m','b','l','e',
+  'r',' ','s','y','n','t','a','x','.',' ','N','o',' ','r','e',
+  'f',' ','w','i','t','h',' ','b','r','a','c','k','e','t','s',
+  ')',#000,'E','_','E','x','p','r','e','s','s','i','o','n','s',
+  ' ','o','f',' ','t','h','e',' ','f','o','r','m',' ','[','s',
+  'r','e','g',':','r','e','g','.','.','.',']',' ','a','r','e',
+  ' ','c','u','r','r','e','n','t','l','y',' ','n','o','t',' ',
+  's','u','p','p','o','r','t','e','d',#000,'E','_','T','r','y',
+  'i','n','g',' ','t','o',' ','d','e','f','i','n','e',' ','a',
+  ' ','s','e','g','m','e','n','t',' ','r','e','g','i','s','t',
+  'e','r',' ','t','w','i','c','e',#000,'E','_','T','r','y','i',
+  'n','g',' ','t','o',' ','d','e','f','i','n','e',' ','a',' ',
+  'b','a','s','e',' ','r','e','g','i','s','t','e','r',' ','t',
+  'w','i','c','e',#000,'E','_','T','r','y','i','n','g',' ','t',
+  'o',' ','u','s','e',' ','a',' ','n','e','g','a','t','i','v',
+  'e',' ','i','n','d','e','x',' ','r','e','g','i','s','t','e',
+  'r',#000,'E','_','A','s','m',' ','s','y','n','t','a','x',' ',
+  'e','r','r','o','r',' ','-',' ','e','r','r','o','r',' ','i',
+  'n',' ','r','e','f','e','r','e','n','c','e',#000,'E','_','L',
+  'o','c','a','l',' ','s','y','m','b','o','l','s',' ','n','o',
+  't',' ','a','l','l','o','w','e','d',' ','a','s',' ','r','e',
+  'f','e','r','e','n','c','e','s',#000,'E','_','I','n','v','a',
+  'l','i','d',' ','o','p','e','r','a','n','d',' ','i','n',' ',
+  'b','r','a','c','k','e','t',' ','e','x','p','r','e','s','s',
+  'i','o','n',#000,'E','_','I','n','v','a','l','i','d',' ','s',
+  'y','m','b','o','l',' ','n','a','m','e',':',' ','$','1',#000,
+  'E','_','I','n','v','a','l','i','d',' ','R','e','f','e','r',
+  'e','n','c','e',' ','s','y','n','t','a','x',#000,'E','_','I',
+  'n','v','a','l','i','d',' ','s','t','r','i','n','g',' ','a',
+  's',' ','o','p','c','o','d','e',' ','o','p','e','r','a','n',
+  'd',':',' ','$','1',#000,'W','_','@','C','O','D','E',' ','a',
+  'n','d',' ','@','D','A','T','A',' ','n','o','t',' ','s','u',
+  'p','p','o','r','t','e','d',#000,'E','_','N','u','l','l',' ',
+  'l','a','b','e','l',' ','r','e','f','e','r','e','n','c','e',
+  's',' ','a','r','e',' ','n','o','t',' ','a','l','l','o','w',
+  'e','d',#000,'E','_','C','a','n','n','o','t',' ','u','s','e',
+  ' ','S','E','L','F',' ','o','u','t','s','i','d','e',' ','a',
+  ' ','m','e','t','h','o','d',#000,'E','_','A','s','m',' ','s',
+  'y','n','t','a','x',' ','e','r','r','o','r',' ','-',' ','S',
+  'h','o','u','l','d',' ','s','t','a','r','t',' ','w','i','t',
+  'h',' ','b','r','a','c','k','e','t',#000,'E','_','A','s','m',
+  ' ','s','y','n','t','a','x',' ','e','r','r','o','r',' ','-',
+  ' ','r','e','g','i','s','t','e','r',':',' ','$','1',#000,'E',
+  '_','S','E','G',' ','a','n','d',' ','O','F','F','S','E','T',
+  ' ','n','o','t',' ','s','u','p','p','o','r','t','e','d',#000,
+  'E','_','A','s','m',' ','s','y','n','t','a','x',' ','e','r',
+  'r','o','r',' ','-',' ','i','n',' ','o','p','c','o','d','e',
+  ' ','o','p','e','r','a','n','d',#000,'E','_','I','n','v','a',
+  'l','i','d',' ','S','t','r','i','n','g',' ','e','x','p','r',
+  'e','s','s','i','o','n',#000,'E','_','C','o','n','s','t','a',
+  'n','t',' ','e','x','p','r','e','s','s','i','o','n',' ','o',
+  'u','t',' ','o','f',' ','b','o','u','n','d','s',#000,'F','_',
+  'I','n','t','e','r','n','a','l',' ','E','r','r','o','r',' ',
+  'i','n',' ','B','u','i','l','d','C','o','n','s','t','a','n',
+  't','(',')',#000,'W','_','A',' ','r','e','p','e','a','t',' ',
+  'p','r','e','f','i','x',' ','a','n','d',' ','a',' ','s','e',
+  'g','m','e','n','t',' ','o','v','e','r','r','i','d','e',' ',
+  'o','n',' ','<','=',' ','i','3','8','6',' ','m','a','y',' ',
+  'r','e','s','u','l','t',' ','i','n',' ','e','r','r','o','r',
+  's',' ','i','f',' ','a','n',' ','i','n','t','e','r','r','u',
+  'p','t',' ','o','c','c','u','r','s',#000,'E','_','I','n','v',
+  'a','l','i','d',' ','o','r',' ','m','i','s','s','i','n','g',
+  ' ','o','p','c','o','d','e',#000,'E','_','I','n','v','a','l',
+  'i','d',' ','c','o','m','b','i','n','a','t','i','o','n',' ',
+  'o','f',' ','p','r','e','f','i','x',' ','a','n','d',' ','o',
+  'p','c','o','d','e',':',' ','$','1',#000,'E','_','I','n','v',
+  'a','l','i','d',' ','c','o','m','b','i','n','a','t','i','o',
+  'n',' ','o','f',' ','o','v','e','r','r','i','d','e',' ','a',
+  'n','d',' ','o','p','c','o','d','e',':',' ','$','1',#000,'E',
+  '_','T','o','o',' ','m','a','n','y',' ','o','p','e','r','a',
+  'n','d','s',' ','o','n',' ','l','i','n','e',#000,'E','_','D',
+  'u','p','l','i','c','a','t','e',' ','l','o','c','a','l',' ',
+  's','y','m','b','o','l',':',' ','$','1',#000,'E','_','U','n',
+  'k','n','o','w','n',' ','l','a','b','e','l',' ','i','d','e',
+  'n','t','i','f','e','r',':',' ','$','1',#000,'E','_','A','s',
+  's','e','m','b','l','e',' ','n','o','d','e',' ','s','y','n',
+  't','a','x',' ','e','r','r','o','r',#000,'E','_','U','n','d',
+  'e','f','i','n','e','d',' ','l','o','c','a','l',' ','s','y',
+  'm','b','o','l',':',' ','$','1',#000,'D','_','S','t','a','r',
+  't','i','n','g',' ','i','n','t','e','l',' ','s','t','y','l',
+  'e','d',' ','a','s','s','e','m','b','l','e','r',' ','p','a',
+  'r','s','i','n','g','.','.','.',#000,'D','_','F','i','n','i',
+  's','h','e','d',' ','i','n','t','e','l',' ','s','t','y','l',
+  'e','d',' ','a','s','s','e','m','b','l','e','r',' ','p','a',
+  'r','s','i','n','g','.','.','.',#000,'E','_','N','o','t',' ',
+  'a',' ','d','i','r','e','c','t','i','v','e',' ','o','r',' ',
+  'l','o','c','a','l',' ','s','y','m','b','o','l',':',' ','$',
+  '1',#000,'E','_','/',' ','a','t',' ','b','e','g','i','n','n',
+  'i','n','g',' ','o','f',' ','l','i','n','e',' ','n','o','t',
+  ' ','a','l','l','o','w','e','d',#000,'E','_','N','O','R',' ',
+  'n','o','t',' ','s','u','p','p','o','r','t','e','d',#000,'E',
+  '_','I','n','v','a','l','i','d',' ','f','l','o','a','t','i',
+  'n','g',' ','p','o','i','n','t',' ','r','e','g','i','s','t',
+  'e','r',' ','n','a','m','e',#000,'W','_','M','o','d','u','l',
+  'o',' ','n','o','t',' ','s','u','p','p','o','r','t','e','d',
+  #000,'E','_','I','n','v','a','l','i','d',' ','f','l','o','a',
+  't','i','n','g',' ','p','o','i','n','t',' ','c','o','n','s',
+  't','a','n','t',':',' ','$','1',#000,'E','_','S','i','z','e',
+  ' ','s','u','f','f','i','x',' ','a','n','d',' ','d','e','s',
+  't','i','n','a','t','i','o','n',' ','r','e','g','i','s','t',
+  'e','r',' ','d','o',' ','n','o','t',' ','m','a','t','c','h',
+  #000,'E','_','I','n','t','e','r','n','a','l',' ','e','r','r',
+  'o','r',' ','i','n',' ','C','o','n','c','a','t','L','a','b',
+  'e','l','e','d','I','n','s','t','r','(',')',#000,'W','_','F',
+  'l','o','a','t','i','n','g',' ','p','o','i','n','t',' ','b',
+  'i','n','a','r','y',' ','r','e','p','r','e','s','e','n','t',
+  'a','t','i','o','n',' ','i','g','n','o','r','e','d',#000,'W',
+  '_','F','l','o','a','t','i','n','g',' ','p','o','i','n','t',
+  ' ','h','e','x','a','d','e','c','i','m','a','l',' ','r','e',
+  'p','r','e','s','e','n','t','a','t','i','o','n',' ','i','g',
+  'n','o','r','e','d',#000,'W','_','F','l','o','a','t','i','n',
+  'g',' ','p','o','i','n','t',' ','o','c','t','a','l',' ','r',
+  'e','p','r','e','s','e','n','t','a','t','i','o','n',' ','i',
+  'g','n','o','r','e','d',#000,'E','_','I','n','v','a','l','i',
+  'd',' ','r','e','a','l',' ','c','o','n','s','t','a','n','t',
+  ' ','e','x','p','r','e','s','s','i','o','n',#000,'E','_','P',
+  'a','r','e','n','t','h','e','s','i','s',' ','a','r','e',' ',
+  'n','o','t',' ','a','l','l','o','w','e','d',#000,'E','_','I',
+  'n','v','a','l','i','d',' ','R','e','f','e','r','e','n','c',
+  'e',#000,'E','_','C','a','n','n','o','t',' ','u','s','e',' ',
+  '_','_','S','E','L','F',' ','o','u','t','s','i','d','e',' ',
+  'a',' ','m','e','t','h','o','d',#000,'E','_','C','a','n','n',
+  'o','t',' ','u','s','e',' ','_','_','O','L','D','E','B','P',
+  ' ','o','u','t','s','i','d','e',' ','a',' ','n','e','s','t',
+  'e','d',' ','p','r','o','c','e','d','u','r','e',#000,'W','_',
+  'I','d','e','n','t','i','f','i','e','r',' ','$','1',' ','s',
+  'u','p','p','o','s','e','d',' ','e','x','t','e','r','n','a',
+  'l',#000,'E','_','I','n','v','a','l','i','d',' ','s','e','g',
+  'm','e','n','t',' ','o','v','e','r','r','i','d','e',' ','e',
+  'x','p','r','e','s','s','i','o','n',#000,'E','_','S','t','r',
+  'i','n','g','s',' ','n','o','t',' ','a','l','l','o','w','e',
+  'd',' ','a','s',' ','c','o','n','s','t','a','n','t','s',#000,
+  'D','_','S','t','a','r','t','i','n','g',' ','A','T','&','T',
+  ' ','s','t','y','l','e','d',' ','a','s','s','e','m','b','l',
+  'e','r',' ','p','a','r','s','i','n','g','.','.','.',#000,'D',
+  '_','F','i','n','i','s','h','e','d',' ','A','T','&','T',' ',
+  's','t','y','l','e','d',' ','a','s','s','e','m','b','l','e',
+  'r',' ','p','a','r','s','i','n','g','.','.','.',#000,'E','_',
+  'S','w','i','t','c','h','i','n','g',' ','s','e','c','t','i',
+  'o','n','s',' ','i','s',' ','n','o','t',' ','a','l','l','o',
+  'w','e','d',' ','i','n',' ','a','n',' ','a','s','s','e','m',
+  'b','l','e','r',' ','b','l','o','c','k',#000,'E','_','I','n',
+  'v','a','l','i','d',' ','g','l','o','b','a','l',' ','d','e',
+  'f','i','n','i','t','i','o','n',#000,'E','_','L','i','n','e',
+  ' ','s','e','p','a','r','a','t','o','r',' ','e','x','p','e',
+  'c','t','e','d',#000,'W','_','g','l','o','b','l',' ','n','o',
+  't',' ','s','u','p','p','o','r','t','e','d',#000,'W','_','a',
+  'l','i','g','n',' ','n','o','t',' ','s','u','p','p','o','r',
+  't','e','d',#000,'W','_','l','c','o','m','m',' ','n','o','t',
+  ' ','s','u','p','p','o','r','t','e','d',#000,'W','_','c','o',
+  'm','m',' ','n','o','t',' ','s','u','p','p','o','r','t','e',
+  'd',#000,'E','_','I','n','v','a','l','i','d',' ','l','o','c',
+  'a','l',' ','c','o','m','m','o','n',' ','d','e','f','i','n',
+  'i','t','i','o','n',#000,'E','_','I','n','v','a','l','i','d',
+  ' ','g','l','o','b','a','l',' ','c','o','m','m','o','n',' ',
+  'd','e','f','i','n','i','t','i','o','n',#000,'E','_','l','o',
+  'c','a','l',' ','s','y','m','b','o','l',':',' ','$','1',' ',
+  'n','o','t',' ','f','o','u','n','d',' ','i','n','s','i','d',
+  'e',' ','a','s','m',' ','s','t','a','t','e','m','e','n','t',
+  #000,'E','_','a','s','s','e','m','b','l','e','r',' ','c','o',
+  'd','e',' ','n','o','t',' ','r','e','t','u','r','n','e','d',
+  ' ','t','o',' ','t','e','x','t',#000,'F','_','i','n','t','e',
+  'r','n','a','l',' ','e','r','r','o','r',' ','i','n',' ','B',
+  'u','i','l','d','R','e','f','e','r','e','n','c','e','(',')',
+  #000,'E','_','i','n','v','a','l','i','d',' ','o','p','c','o',
+  'd','e',' ','s','i','z','e',#000,'W','_','N','E','A','R',' ',
+  'i','g','n','o','r','e','d',#000,'W','_','F','A','R',' ','i',
+  'g','n','o','r','e','d',#000,'D','_','C','r','e','a','t','i',
+  'n','g',' ','i','n','l','i','n','e',' ','a','s','m',' ','l',
+  'o','o','k','u','p',' ','t','a','b','l','e','s',#000,'W','_',
+  'U','s','i','n','g',' ','a',' ','d','e','f','i','n','e','d',
+  ' ','n','a','m','e',' ','a','s',' ','a',' ','l','o','c','a',
+  'l',' ','l','a','b','e','l',#000,'F','_','i','n','t','e','r',
+  'n','a','l',' ','e','r','r','o','r',' ','i','n',' ','H','a',
+  'n','d','l','e','E','x','t','e','n','d','(',')',#000,'E','_',
+  'I','n','v','a','l','i','d',' ','c','h','a','r','a','c','t',
+  'e','r',':',' ','<',#000,'E','_','I','n','v','a','l','i','d',
+  ' ','c','h','a','r','a','c','t','e','r',':',' ','>',#000,'E',
+  '_','U','n','s','u','p','p','o','r','t','e','d',' ','o','p',
+  'c','o','d','e',#000,'E','_','I','n','c','r','e','m','e','n',
+  't',' ','a','n','d',' ','D','e','c','r','e','m','e','n','t',
+  ' ','m','o','d','e',' ','n','o','t',' ','a','l','l','o','w',
+  'e','d',' ','t','o','g','e','t','h','e','r',#000,'E','_','I',
+  'n','v','a','l','i','d',' ','R','e','g','i','s','t','e','r',
+  ' ','l','i','s','t',' ','i','n',' ','m','o','v','e','m','/',
+  'f','m','o','v','e','m',#000,'E','_','I','n','v','a','l','i',
+  'd',' ','R','e','g','i','s','t','e','r',' ','l','i','s','t',
+  ' ','f','o','r',' ','o','p','c','o','d','e',#000,'E','_','6',
+  '8','0','2','0','+',' ','m','o','d','e',' ','r','e','q','u',
+  'i','r','e','d',' ','t','o',' ','a','s','s','e','m','b','l',
+  'e',#000,'D','_','S','t','a','r','t','i','n','g',' ','M','o',
+  't','o','r','o','l','a',' ','s','t','y','l','e','d',' ','a',
+  's','s','e','m','b','l','e','r',' ','p','a','r','s','i','n',
+  'g','.','.','.',#000,'D','_','F','i','n','i','s','h','e','d',
+  ' ','M','o','t','o','r','o','l','a',' ','s','t','y','l','e',
+  'd',' ','a','s','s','e','m','b','l','e','r',' ','p','a','r',
+  's','i','n','g','.','.','.',#000,'W','_','X','D','E','F',' ',
+  'n','o','t',' ','s','u','p','p','o','r','t','e','d',#000,'W',
+  '_','F','u','n','c','t','i','o','n','s',' ','w','i','t','h',
+  ' ','v','o','i','d',' ','r','e','t','u','r','n',' ','v','a',
+  'l','u','e',' ','c','a','n',#039,'t',' ','r','e','t','u','r',
+  'n',' ','a','n','y',' ','v','a','l','u','e',' ','i','n',' ',
+  'a','s','m',' ','c','o','d','e',#000,'E','_','I','n','v','a',
+  'l','i','d',' ','s','u','f','f','i','x',' ','f','o','r',' ',
+  'i','n','t','e','l',' ','a','s','s','e','m','b','l','e','r',
+  #000,'E','_','E','x','t','e','n','d','e','d',' ','n','o','t',
+  ' ','s','u','p','p','o','r','t','e','d',' ','i','n',' ','t',
+  'h','i','s',' ','m','o','d','e',#000,'E','_','C','o','m','p',
+  ' ','n','o','t',' ','s','u','p','p','o','r','t','e','d',' ',
+  'i','n',' ','t','h','i','s',' ','m','o','d','e',#000,'W','_',
+  'Y','o','u',' ','n','e','e','d',' ','G','N','U',' ','a','s',
+  ' ','v','e','r','s','i','o','n',' ','>','=',' ','2','.','8',
+  '1',' ','t','o',' ','c','o','m','p','i','l','e',' ','t','h',
+  'i','s',' ','M','M','X',' ','c','o','d','e',#000,'I','_','A',
+  's','s','e','m','b','l','i','n','g',' ','(','p','i','p','e',
+  ')',' ','$','1',#000,'E','_','C','a','n',#039,'t',' ','c','r',
+  'e','a','t','e',' ','a','s','s','e','m','b','e','r',' ','f',
+  'i','l','e',' ','$','1',#000,'W','_','A','s','s','e','m','b',
+  'l','e','r',' ','$','1',' ','n','o','t',' ','f','o','u','n',
+  'd',',',' ','s','w','i','t','c','h','i','n','g',' ','t','o',
+  ' ','e','x','t','e','r','n','a','l',' ','a','s','s','e','m',
+  'b','l','i','n','g',#000,'U','_','U','s','i','n','g',' ','a',
+  's','s','e','m','b','l','e','r',':',' ','$','1',#000,'W','_',
+  'E','r','r','o','r',' ','w','h','i','l','e',' ','a','s','s',
+  'e','m','b','l','i','n','g',#000,'W','_','C','a','n',#039,'t',
+  ' ','c','a','l','l',' ','t','h','e',' ','a','s','s','e','m',
+  'b','l','e','r',',',' ','s','w','i','t','c','h','i','n','g',
+  ' ','t','o',' ','e','x','t','e','r','n','a','l',' ','a','s',
+  's','e','m','b','l','i','n','g',#000,'I','_','A','s','s','e',
+  'm','b','l','i','n','g',' ','$','1',#000,'W','_','L','i','n',
+  'k','e','r',' ','$','1',' ','n','o','t',' ','f','o','u','n',
+  'd',',',' ','s','w','i','t','c','h','i','n','g',' ','t','o',
+  ' ','e','x','t','e','r','n','a','l',' ','l','i','n','k','i',
+  'n','g',#000,'U','_','U','s','i','n','g',' ','l','i','n','k',
+  'e','r',':',' ','$','1',#000,'E','_','F','i','l','e',' ','$',
+  '1',' ','n','o','t',' ','f','o','u','n','d',',',' ','L','i',
+  'n','k','i','n','g',' ','m','a','y',' ','f','a','i','l',' ',
+  '!','!',#000,'W','_','E','r','r','o','r',' ','w','h','i','l',
+  'e',' ','l','i','n','k','i','n','g',#000,'W','_','C','a','n',
+  #039,'t',' ','c','a','l','l',' ','t','h','e',' ','l','i','n',
+  'k','e','r',',',' ','s','w','i','t','c','h','i','n','g',' ',
+  't','o',' ','e','x','t','e','r','n','a','l',' ','l','i','n',
+  'k','i','n','g',#000,'I','_','L','i','n','k','i','n','g',' ',
+  '$','1',#000,'W','_','b','i','n','d','e','r',' ','n','o','t',
+  ' ','f','o','u','n','d',',',' ','s','w','i','t','c','h','i',
+  'n','g',' ','t','o',' ','e','x','t','e','r','n','a','l',' ',
+  'b','i','n','d','i','n','g',#000,'W','_','a','r',' ','n','o',
+  't',' ','f','o','u','n','d',',',' ','s','w','i','t','c','h',
+  'i','n','g',' ','t','o',' ','e','x','t','e','r','n','a','l',
+  ' ','a','r',#000,'E','_','D','y','n','a','m','i','c',' ','L',
+  'i','b','r','a','r','i','e','s',' ','n','o','t',' ','s','u',
+  'p','p','o','r','t','e','d',#000,'I','_','C','l','o','s','i',
+  'n','g',' ','s','c','r','i','p','t',' ','$','1',#000,'U','_',
+  'P','P','U',' ','L','o','a','d','i','n','g',' ','$','1',#000,
+  'D','_','P','P','U',' ','T','i','m','e',':',' ','$','1',#000,
+  'D','_','P','P','U',' ','F','i','l','e',' ','t','o','o',' ',
+  's','h','o','r','t',#000,'D','_','P','P','U',' ','I','n','v',
+  'a','l','i','d',' ','H','e','a','d','e','r',' ','(','n','o',
+  ' ','P','P','U',' ','a','t',' ','t','h','e',' ','b','e','g',
+  'i','n',')',#000,'D','_','P','P','U',' ','I','n','v','a','l',
+  'i','d',' ','V','e','r','s','i','o','n',' ','$','1',#000,'D',
+  '_','P','P','U',' ','F','l','a','g','s',':',' ','$','1',#000,
+  'D','_','P','P','U',' ','C','r','c',':',' ','$','1',#000,'T',
+  '_','P','P','U',' ','S','o','u','r','c','e',':',' ','$','1',
+  #000,'D','_','o','b','j','e','c','t','f','i','l','e',' ','a',
+  'n','d',' ','a','s','s','e','m','b','l','e','r','f','i','l',
+  'e',' ','a','r','e',' ','o','l','d','e','r',' ','t','h','a',
+  'n',' ','p','p','u','f','i','l','e',#000,'D','_','o','b','j',
+  'e','c','t','f','i','l','e',' ','i','s',' ','o','l','d','e',
+  'r',' ','t','h','a','n',' ','a','s','s','e','m','b','l','e',
+  'r','f','i','l','e',#000,'T','_','U','n','i','t','s','e','a',
+  'r','c','h',':',' ','$','1',#000,'U','_','W','r','i','t','i',
+  'n','g',' ','$','1',#000,'F','_','C','a','n',#039,'t',' ','W',
+  'r','i','t','e',' ','P','P','U','-','F','i','l','e',#000,'F',
+  '_','r','e','a','d','i','n','g',' ','P','P','U','-','F','i',
+  'l','e',#000,'F','_','I','n','v','a','l','i','d',' ','P','P',
+  'U','-','F','i','l','e',' ','e','n','t','r','y',':',' ','$',
+  '1',#000,'F','_','P','P','U',' ','D','b','x',' ','c','o','u',
+  'n','t',' ','p','r','o','b','l','e','m',#000,'E','_','I','l',
+  'l','e','g','a','l',' ','u','n','i','t',' ','n','a','m','e',
+  ':',' ','$','1',#000,'F','_','T','o','o',' ','m','u','c','h',
+  ' ','u','n','i','t','s',#000,'F','_','C','i','r','c','u','l',
+  'a','r',' ','u','n','i','t',' ','r','e','f','e','r','e','n',
+  'c','e',#000,'F','_','C','a','n',#039,'t',' ','c','o','m','p',
+  'i','l','e',' ','u','n','i','t',' ','$','1',',',' ','n','o',
+  ' ','s','o','u','r','c','e','s',' ','a','v','a','i','l','a',
+  'b','l','e',#000,'W','_','C','o','m','p','i','l','i','n','g',
+  ' ','t','h','e',' ','s','y','s','t','e','m',' ','u','n','i',
+  't',' ','r','e','q','u','i','r','e','s',' ','t','h','e',' ',
+  '-','U','s',' ','s','w','i','t','c','h',#000,'E','_','$','1',
+  ' ','E','r','r','o','r','s',#000,'F','_','T','h','e','r','e',
+  ' ','w','e','r','e',' ','e','r','r','o','r','s',' ','c','o',
+  'm','p','i','l','i','n','g',' ','m','o','d','u','l','e',',',
+  ' ','c','o','m','p','i','l','a','t','i','o','n',' ','s','t',
+  'o','p','p','e','d',#000);

compiler/optidx.inc

@@ -0,0 +1,55 @@
+{
+    $Id$
+    Copyright (c) 1998 by the FPC development team
+
+    This file includes the message index types which can be used to display
+    a message from the message file
+
+    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.
+
+ ****************************************************************************}
+
+const
+  optionhelplines=117; {amount of lines for the -?}
+type
+  toptionconst=(
+usage,
+only_one_source_support,
+def_only_for_os2,
+no_nested_response_file,
+no_source_found,
+illegal_para,
+help_pages_para,
+unable_open_file,
+reading_further_from,
+target_is_already_set,
+no_shared_lib_under_dos,
+too_many_ifdef,
+too_many_endif,
+too_less_endif,
+{logo}
+logo_start,
+logo_end,
+{info}
+info_start,
+info1,
+info2,
+info3,
+info4,
+info5,
+info_end,
+{This should be the last}
+endoptionconst
+);

compiler/optione.msg

@@ -0,0 +1,157 @@
+ [options] <inputfile> [options]
+Only one source file supported
+DEF file can be created only for OS/2
+nested response files are not supported
+No source file name in command line
+Illegal parameter: $1
+-? writes help pages
+Unable to open file $1
+Reading further options from $1
+Target is already set to: $1
+Shared libs not supported on DOS platform, reverting to static
+too many IF(N)DEFs
+too many ENDIFs
+open conditional at the end of the file
+;
+; Logo
+;
+Free Pascal Compiler version 0.99.0 for $1
+Copyright (c) 1993-98 by Florian Klaempfl
+;
+; Info
+;
+Free Pascal Compiler version 0.99.0
+<lf>
+This program comes under the GNU General Public Licence
+For more information read COPYING
+<lf>
+Report bugs,suggestions etc to:
+                [email protected]
+;
+; The -? help pages
+;
+; XXX<X>_<Text>
+; ||| +- letter(s)  [ the option letter(s) ]
+; ||+-- ident       [ 0123 level 0,1,2,3 ]
+; |+--- OS          [ L,D,W,O,t(TP),*(all) ]
+; +---- Processor   [ 3,6,*(all) ]
+;
+**0*_+ switch option on, - off
+**1a_the compiler doesn''t delete the generated assembler file
+*t1b_use EMS
+**1B+_build
+**1C_code generation options
+**2Ca_not implemented
+**2Ce_not implemented
+3*2CD_Dynamic linking
+**2Ch<n>_<n> bytes heap (between 1023 and 67107840)
+**2Ci_IO-checking
+**2Cn_omit linking stage
+**2Co_check overflow of integer operations
+**2Cr_range checking
+*O2Cs<n>_set stack size to <n>
+**2Ct_stack checking
+3*2CS_static linking
+**1d<x>_defines the symbol <x>
+*O1D_controls the generation of DEF file (only OS/2)
+*O2Dd<x>_set description to <x>
+*O2Do_generate DEF file
+*O2Dw_PM application
+*L1e<x>_set path to executables
+**1E_same as -Cn
+**1g_generate debugger information
+**2gp_generate also profile code for gprof
+**1F_set file names and paths
+**2Fe<x>_redirect error output to <x>
+*L2Fg<x>_<x> search path for the GNU C lib
+*L2Fr<x>_<x> search path for the error message file
+**2Fi<x>_adds <x> to include path
+**2Fl<x>_adds <x> to library path
+**2Fu<x>_adds <x> to unit path
+**1k<x>_Pass <x> to the linker
+**1L_set language
+**2LD_german
+**2LE_english
+**1l_write logo
+**1i_information
+**1n_don't read the default config file
+**1o<x>_change the name of the executable produced to <x>
+**1pg_generate profile code for gprof
+*L1P_use pipes instead of creating temporary assembler files
+**1S_syntax options
+**2S2_switch some Delphi 2 extension on
+**2Sa_semantic check of expressions (higher level includes lower)
+**3Sa4_assigment results are typed (allows a:=b:=0)
+**3Sa9_allows expressions with no side effect
+**2Sc_supports operators like C (*=,+=,/= and -=)
+**2Sg_allows LABEL and GOTO
+**2Si_support C++ stlyed INLINE
+**2Sm_support macros like C (global)
+**2So_tries to be TP/BP 7.0 compatible
+**2Ss_constructor name must be init (destructor must be done)
+**2St_allows static keyword in objects
+**1s_don't call assembler and linker (only with -a)
+**1T<x>_Target operating system
+3*2TDOS_DOS extender by DJ Delorie
+3*2TOS2_OS/2 2.x
+3*2TLINUX_Linux
+3*2TWin32_Windows 32 Bit
+3*2TGO32V2_version 2 of DJ Delorie DOS extender
+6*2TAMIGA_Commodore Amiga
+6*2TATARI_Atari ST/STe/TT
+6*2TMACOS_Macintosh m68k
+6*2TLINUX_Linux-68k
+**1u<x>_undefines the symbol <x>
+**1U_unit options
+**2Uls_make static library from unit
+**2Uld_make dynamic library from unit
+**2Un_don't check the unit name
+**2Up<x>_same as -Fu<x>
+**2Us_compile a system unit
+**1v<x>_Be verbose. <x> is a combination of the following letters :
+**2*_e : Show errors (default)       d : Show debug info
+**2*_w : Show warnings               u : Show used files
+**2*_n : Show notes                  t : Show tried files
+**2*_h : Show hints                  m : Show defined macros
+**2*_i : Show general info           p : Show compiled procedures
+**2*_l : Show linenumbers            c : Show conditionals
+**2*_a : Show everything             0 : Show nothing (except errors)
+**1X_executable options
+*L2Xc_link with the c library
+**2Xs_strip all symbols from executable
+**0*_Processor specific options:
+3*1A_output format
+3*2Aatt_AT&T assembler
+3*2Ao_coff file using GNU AS
+3*2Aobj_OMF file using NASM
+3*2Anasm_coff file using NASM
+3*2Amasm_assembler for the Microsoft/Borland/Watcom assembler
+3*1R_assembler reading style
+3*2Ratt_read AT&T style assembler
+3*2Rintel_read Intel style assembler
+3*2Rdirect_copy assembler text directly to assembler file
+3*1O_optimizations
+3*2Oa_simple optimizations
+3*2Og_optimize for size
+3*2OG_optimize for time
+3*2Ox_optimize maximum
+3*2Oz_uncertain optimizes (see docs)
+3*2O2_optimize for Pentium II (tm)
+3*2O3_optimize for i386
+3*2O4_optimize for i486
+3*2O5_optimize for Pentium (tm)
+3*2O6_optimizations for PentiumPro (tm)
+6*1A_output format
+6*2Agas_GNU Motorola assembler
+6*2Ao_UNIX o-file
+6*2Am_Standard Motorola assembler
+6*2Ai_MIT Syntax (old GAS)
+6*1O_optimizations
+6*2Oa_simple optimizations
+6*2Og_optimize for size
+6*2OG_optimize for time
+6*2Ox_optimize maximum
+6*2O2_target is a MC68020+ processor
+**1*_
+**1?_shows this help
+**1h_shows this help without waiting

compiler/optmsg.inc

@@ -0,0 +1,316 @@
+const optiontxt : array[1..04715] of char=(
+  ' ','[','o','p','t','i','o','n','s',']',' ','<','i','n','p',
+  'u','t','f','i','l','e','>',' ','[','o','p','t','i','o','n',
+  's',']',#000,'O','n','l','y',' ','o','n','e',' ','s','o','u',
+  'r','c','e',' ','f','i','l','e',' ','s','u','p','p','o','r',
+  't','e','d',#000,'D','E','F',' ','f','i','l','e',' ','c','a',
+  'n',' ','b','e',' ','c','r','e','a','t','e','d',' ','o','n',
+  'l','y',' ','f','o','r',' ','O','S','/','2',#000,'n','e','s',
+  't','e','d',' ','r','e','s','p','o','n','s','e',' ','f','i',
+  'l','e','s',' ','a','r','e',' ','n','o','t',' ','s','u','p',
+  'p','o','r','t','e','d',#000,'N','o',' ','s','o','u','r','c',
+  'e',' ','f','i','l','e',' ','n','a','m','e',' ','i','n',' ',
+  'c','o','m','m','a','n','d',' ','l','i','n','e',#000,'I','l',
+  'l','e','g','a','l',' ','p','a','r','a','m','e','t','e','r',
+  ':',' ','$','1',#000,'-','?',' ','w','r','i','t','e','s',' ',
+  'h','e','l','p',' ','p','a','g','e','s',#000,'U','n','a','b',
+  'l','e',' ','t','o',' ','o','p','e','n',' ','f','i','l','e',
+  ' ','$','1',#000,'R','e','a','d','i','n','g',' ','f','u','r',
+  't','h','e','r',' ','o','p','t','i','o','n','s',' ','f','r',
+  'o','m',' ','$','1',#000,'T','a','r','g','e','t',' ','i','s',
+  ' ','a','l','r','e','a','d','y',' ','s','e','t',' ','t','o',
+  ':',' ','$','1',#000,'S','h','a','r','e','d',' ','l','i','b',
+  's',' ','n','o','t',' ','s','u','p','p','o','r','t','e','d',
+  ' ','o','n',' ','D','O','S',' ','p','l','a','t','f','o','r',
+  'm',',',' ','r','e','v','e','r','t','i','n','g',' ','t','o',
+  ' ','s','t','a','t','i','c',#000,'t','o','o',' ','m','a','n',
+  'y',' ','I','F','(','N',')','D','E','F','s',#000,'t','o','o',
+  ' ','m','a','n','y',' ','E','N','D','I','F','s',#000,'o','p',
+  'e','n',' ','c','o','n','d','i','t','i','o','n','a','l',' ',
+  'a','t',' ','t','h','e',' ','e','n','d',' ','o','f',' ','t',
+  'h','e',' ','f','i','l','e',#000,'F','r','e','e',' ','P','a',
+  's','c','a','l',' ','C','o','m','p','i','l','e','r',' ','v',
+  'e','r','s','i','o','n',' ','0','.','9','9','.','0',' ','f',
+  'o','r',' ','$','1',#000,'C','o','p','y','r','i','g','h','t',
+  ' ','(','c',')',' ','1','9','9','3','-','9','8',' ','b','y',
+  ' ','F','l','o','r','i','a','n',' ','K','l','a','e','m','p',
+  'f','l',#000,'F','r','e','e',' ','P','a','s','c','a','l',' ',
+  'C','o','m','p','i','l','e','r',' ','v','e','r','s','i','o',
+  'n',' ','0','.','9','9','.','0',#000,#000,'T','h','i','s',' ',
+  'p','r','o','g','r','a','m',' ','c','o','m','e','s',' ','u',
+  'n','d','e','r',' ','t','h','e',' ','G','N','U',' ','G','e',
+  'n','e','r','a','l',' ','P','u','b','l','i','c',' ','L','i',
+  'c','e','n','c','e',#000,'F','o','r',' ','m','o','r','e',' ',
+  'i','n','f','o','r','m','a','t','i','o','n',' ','r','e','a',
+  'd',' ','C','O','P','Y','I','N','G',#000,#000,'R','e','p','o',
+  'r','t',' ','b','u','g','s',',','s','u','g','g','e','s','t',
+  'i','o','n','s',' ','e','t','c',' ','t','o',':',#000,' ',' ',
+  ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ','k',
+  'l','a','e','m','p','f','l','@','h','a','e','g','a','r','.',
+  'c','i','p','.','m','w','.','t','u','-','m','u','e','n','c',
+  'h','e','n','.','d','e',#000,'*','*','0','*','_','+',' ','s',
+  'w','i','t','c','h',' ','o','p','t','i','o','n',' ','o','n',
+  ',',' ','-',' ','o','f','f',#000,'*','*','1','a','_','t','h',
+  'e',' ','c','o','m','p','i','l','e','r',' ','d','o','e','s',
+  'n',#039,#039,'t',' ','d','e','l','e','t','e',' ','t','h','e',
+  ' ','g','e','n','e','r','a','t','e','d',' ','a','s','s','e',
+  'm','b','l','e','r',' ','f','i','l','e',#000,'*','t','1','b',
+  '_','u','s','e',' ','E','M','S',#000,'*','*','1','B','+','_',
+  'b','u','i','l','d',#000,'*','*','1','C','_','c','o','d','e',
+  ' ','g','e','n','e','r','a','t','i','o','n',' ','o','p','t',
+  'i','o','n','s',#000,'*','*','2','C','a','_','n','o','t',' ',
+  'i','m','p','l','e','m','e','n','t','e','d',#000,'*','*','2',
+  'C','e','_','n','o','t',' ','i','m','p','l','e','m','e','n',
+  't','e','d',#000,'3','*','2','C','D','_','D','y','n','a','m',
+  'i','c',' ','l','i','n','k','i','n','g',#000,'*','*','2','C',
+  'h','<','n','>','_','<','n','>',' ','b','y','t','e','s',' ',
+  'h','e','a','p',' ','(','b','e','t','w','e','e','n',' ','1',
+  '0','2','3',' ','a','n','d',' ','6','7','1','0','7','8','4',
+  '0',')',#000,'*','*','2','C','i','_','I','O','-','c','h','e',
+  'c','k','i','n','g',#000,'*','*','2','C','n','_','o','m','i',
+  't',' ','l','i','n','k','i','n','g',' ','s','t','a','g','e',
+  #000,'*','*','2','C','o','_','c','h','e','c','k',' ','o','v',
+  'e','r','f','l','o','w',' ','o','f',' ','i','n','t','e','g',
+  'e','r',' ','o','p','e','r','a','t','i','o','n','s',#000,'*',
+  '*','2','C','r','_','r','a','n','g','e',' ','c','h','e','c',
+  'k','i','n','g',#000,'*','O','2','C','s','<','n','>','_','s',
+  'e','t',' ','s','t','a','c','k',' ','s','i','z','e',' ','t',
+  'o',' ','<','n','>',#000,'*','*','2','C','t','_','s','t','a',
+  'c','k',' ','c','h','e','c','k','i','n','g',#000,'3','*','2',
+  'C','S','_','s','t','a','t','i','c',' ','l','i','n','k','i',
+  'n','g',#000,'*','*','1','d','<','x','>','_','d','e','f','i',
+  'n','e','s',' ','t','h','e',' ','s','y','m','b','o','l',' ',
+  '<','x','>',#000,'*','O','1','D','_','c','o','n','t','r','o',
+  'l','s',' ','t','h','e',' ','g','e','n','e','r','a','t','i',
+  'o','n',' ','o','f',' ','D','E','F',' ','f','i','l','e',' ',
+  '(','o','n','l','y',' ','O','S','/','2',')',#000,'*','O','2',
+  'D','d','<','x','>','_','s','e','t',' ','d','e','s','c','r',
+  'i','p','t','i','o','n',' ','t','o',' ','<','x','>',#000,'*',
+  'O','2','D','o','_','g','e','n','e','r','a','t','e',' ','D',
+  'E','F',' ','f','i','l','e',#000,'*','O','2','D','w','_','P',
+  'M',' ','a','p','p','l','i','c','a','t','i','o','n',#000,'*',
+  'L','1','e','<','x','>','_','s','e','t',' ','p','a','t','h',
+  ' ','t','o',' ','e','x','e','c','u','t','a','b','l','e','s',
+  #000,'*','*','1','E','_','s','a','m','e',' ','a','s',' ','-',
+  'C','n',#000,'*','*','1','g','_','g','e','n','e','r','a','t',
+  'e',' ','d','e','b','u','g','g','e','r',' ','i','n','f','o',
+  'r','m','a','t','i','o','n',#000,'*','*','2','g','p','_','g',
+  'e','n','e','r','a','t','e',' ','a','l','s','o',' ','p','r',
+  'o','f','i','l','e',' ','c','o','d','e',' ','f','o','r',' ',
+  'g','p','r','o','f',#000,'*','*','1','F','_','s','e','t',' ',
+  'f','i','l','e',' ','n','a','m','e','s',' ','a','n','d',' ',
+  'p','a','t','h','s',#000,'*','*','2','F','e','<','x','>','_',
+  'r','e','d','i','r','e','c','t',' ','e','r','r','o','r',' ',
+  'o','u','t','p','u','t',' ','t','o',' ','<','x','>',#000,'*',
+  'L','2','F','g','<','x','>','_','<','x','>',' ','s','e','a',
+  'r','c','h',' ','p','a','t','h',' ','f','o','r',' ','t','h',
+  'e',' ','G','N','U',' ','C',' ','l','i','b',#000,'*','L','2',
+  'F','r','<','x','>','_','<','x','>',' ','s','e','a','r','c',
+  'h',' ','p','a','t','h',' ','f','o','r',' ','t','h','e',' ',
+  'e','r','r','o','r',' ','m','e','s','s','a','g','e',' ','f',
+  'i','l','e',#000,'*','*','2','F','i','<','x','>','_','a','d',
+  'd','s',' ','<','x','>',' ','t','o',' ','i','n','c','l','u',
+  'd','e',' ','p','a','t','h',#000,'*','*','2','F','l','<','x',
+  '>','_','a','d','d','s',' ','<','x','>',' ','t','o',' ','l',
+  'i','b','r','a','r','y',' ','p','a','t','h',#000,'*','*','2',
+  'F','u','<','x','>','_','a','d','d','s',' ','<','x','>',' ',
+  't','o',' ','u','n','i','t',' ','p','a','t','h',#000,'*','*',
+  '1','k','<','x','>','_','P','a','s','s',' ','<','x','>',' ',
+  't','o',' ','t','h','e',' ','l','i','n','k','e','r',#000,'*',
+  '*','1','L','_','s','e','t',' ','l','a','n','g','u','a','g',
+  'e',#000,'*','*','2','L','D','_','g','e','r','m','a','n',#000,
+  '*','*','2','L','E','_','e','n','g','l','i','s','h',#000,'*',
+  '*','1','l','_','w','r','i','t','e',' ','l','o','g','o',#000,
+  '*','*','1','i','_','i','n','f','o','r','m','a','t','i','o',
+  'n',#000,'*','*','1','n','_','d','o','n',#039,'t',' ','r','e',
+  'a','d',' ','t','h','e',' ','d','e','f','a','u','l','t',' ',
+  'c','o','n','f','i','g',' ','f','i','l','e',#000,'*','*','1',
+  'o','<','x','>','_','c','h','a','n','g','e',' ','t','h','e',
+  ' ','n','a','m','e',' ','o','f',' ','t','h','e',' ','e','x',
+  'e','c','u','t','a','b','l','e',' ','p','r','o','d','u','c',
+  'e','d',' ','t','o',' ','<','x','>',#000,'*','*','1','p','g',
+  '_','g','e','n','e','r','a','t','e',' ','p','r','o','f','i',
+  'l','e',' ','c','o','d','e',' ','f','o','r',' ','g','p','r',
+  'o','f',#000,'*','L','1','P','_','u','s','e',' ','p','i','p',
+  'e','s',' ','i','n','s','t','e','a','d',' ','o','f',' ','c',
+  'r','e','a','t','i','n','g',' ','t','e','m','p','o','r','a',
+  'r','y',' ','a','s','s','e','m','b','l','e','r',' ','f','i',
+  'l','e','s',#000,'*','*','1','S','_','s','y','n','t','a','x',
+  ' ','o','p','t','i','o','n','s',#000,'*','*','2','S','2','_',
+  's','w','i','t','c','h',' ','s','o','m','e',' ','D','e','l',
+  'p','h','i',' ','2',' ','e','x','t','e','n','s','i','o','n',
+  ' ','o','n',#000,'*','*','2','S','a','_','s','e','m','a','n',
+  't','i','c',' ','c','h','e','c','k',' ','o','f',' ','e','x',
+  'p','r','e','s','s','i','o','n','s',' ','(','h','i','g','h',
+  'e','r',' ','l','e','v','e','l',' ','i','n','c','l','u','d',
+  'e','s',' ','l','o','w','e','r',')',#000,'*','*','3','S','a',
+  '4','_','a','s','s','i','g','m','e','n','t',' ','r','e','s',
+  'u','l','t','s',' ','a','r','e',' ','t','y','p','e','d',' ',
+  '(','a','l','l','o','w','s',' ','a',':','=','b',':','=','0',
+  ')',#000,'*','*','3','S','a','9','_','a','l','l','o','w','s',
+  ' ','e','x','p','r','e','s','s','i','o','n','s',' ','w','i',
+  't','h',' ','n','o',' ','s','i','d','e',' ','e','f','f','e',
+  'c','t',#000,'*','*','2','S','c','_','s','u','p','p','o','r',
+  't','s',' ','o','p','e','r','a','t','o','r','s',' ','l','i',
+  'k','e',' ','C',' ','(','*','=',',','+','=',',','/','=',' ',
+  'a','n','d',' ','-','=',')',#000,'*','*','2','S','g','_','a',
+  'l','l','o','w','s',' ','L','A','B','E','L',' ','a','n','d',
+  ' ','G','O','T','O',#000,'*','*','2','S','i','_','s','u','p',
+  'p','o','r','t',' ','C','+','+',' ','s','t','l','y','e','d',
+  ' ','I','N','L','I','N','E',#000,'*','*','2','S','m','_','s',
+  'u','p','p','o','r','t',' ','m','a','c','r','o','s',' ','l',
+  'i','k','e',' ','C',' ','(','g','l','o','b','a','l',')',#000,
+  '*','*','2','S','o','_','t','r','i','e','s',' ','t','o',' ',
+  'b','e',' ','T','P','/','B','P',' ','7','.','0',' ','c','o',
+  'm','p','a','t','i','b','l','e',#000,'*','*','2','S','s','_',
+  'c','o','n','s','t','r','u','c','t','o','r',' ','n','a','m',
+  'e',' ','m','u','s','t',' ','b','e',' ','i','n','i','t',' ',
+  '(','d','e','s','t','r','u','c','t','o','r',' ','m','u','s',
+  't',' ','b','e',' ','d','o','n','e',')',#000,'*','*','2','S',
+  't','_','a','l','l','o','w','s',' ','s','t','a','t','i','c',
+  ' ','k','e','y','w','o','r','d',' ','i','n',' ','o','b','j',
+  'e','c','t','s',#000,'*','*','1','s','_','d','o','n',#039,'t',
+  ' ','c','a','l','l',' ','a','s','s','e','m','b','l','e','r',
+  ' ','a','n','d',' ','l','i','n','k','e','r',' ','(','o','n',
+  'l','y',' ','w','i','t','h',' ','-','a',')',#000,'*','*','1',
+  'T','<','x','>','_','T','a','r','g','e','t',' ','o','p','e',
+  'r','a','t','i','n','g',' ','s','y','s','t','e','m',#000,'3',
+  '*','2','T','D','O','S','_','D','O','S',' ','e','x','t','e',
+  'n','d','e','r',' ','b','y',' ','D','J',' ','D','e','l','o',
+  'r','i','e',#000,'3','*','2','T','O','S','2','_','O','S','/',
+  '2',' ','2','.','x',#000,'3','*','2','T','L','I','N','U','X',
+  '_','L','i','n','u','x',#000,'3','*','2','T','W','i','n','3',
+  '2','_','W','i','n','d','o','w','s',' ','3','2',' ','B','i',
+  't',#000,'3','*','2','T','G','O','3','2','V','2','_','v','e',
+  'r','s','i','o','n',' ','2',' ','o','f',' ','D','J',' ','D',
+  'e','l','o','r','i','e',' ','D','O','S',' ','e','x','t','e',
+  'n','d','e','r',#000,'6','*','2','T','A','M','I','G','A','_',
+  'C','o','m','m','o','d','o','r','e',' ','A','m','i','g','a',
+  #000,'6','*','2','T','A','T','A','R','I','_','A','t','a','r',
+  'i',' ','S','T','/','S','T','e','/','T','T',#000,'6','*','2',
+  'T','M','A','C','O','S','_','M','a','c','i','n','t','o','s',
+  'h',' ','m','6','8','k',#000,'6','*','2','T','L','I','N','U',
+  'X','_','L','i','n','u','x','-','6','8','k',#000,'*','*','1',
+  'u','<','x','>','_','u','n','d','e','f','i','n','e','s',' ',
+  't','h','e',' ','s','y','m','b','o','l',' ','<','x','>',#000,
+  '*','*','1','U','_','u','n','i','t',' ','o','p','t','i','o',
+  'n','s',#000,'*','*','2','U','l','s','_','m','a','k','e',' ',
+  's','t','a','t','i','c',' ','l','i','b','r','a','r','y',' ',
+  'f','r','o','m',' ','u','n','i','t',#000,'*','*','2','U','l',
+  'd','_','m','a','k','e',' ','d','y','n','a','m','i','c',' ',
+  'l','i','b','r','a','r','y',' ','f','r','o','m',' ','u','n',
+  'i','t',#000,'*','*','2','U','n','_','d','o','n',#039,'t',' ',
+  'c','h','e','c','k',' ','t','h','e',' ','u','n','i','t',' ',
+  'n','a','m','e',#000,'*','*','2','U','p','<','x','>','_','s',
+  'a','m','e',' ','a','s',' ','-','F','u','<','x','>',#000,'*',
+  '*','2','U','s','_','c','o','m','p','i','l','e',' ','a',' ',
+  's','y','s','t','e','m',' ','u','n','i','t',#000,'*','*','1',
+  'v','<','x','>','_','B','e',' ','v','e','r','b','o','s','e',
+  '.',' ','<','x','>',' ','i','s',' ','a',' ','c','o','m','b',
+  'i','n','a','t','i','o','n',' ','o','f',' ','t','h','e',' ',
+  'f','o','l','l','o','w','i','n','g',' ','l','e','t','t','e',
+  'r','s',' ',':',#000,'*','*','2','*','_','e',' ',':',' ','S',
+  'h','o','w',' ','e','r','r','o','r','s',' ','(','d','e','f',
+  'a','u','l','t',')',' ',' ',' ',' ',' ',' ',' ','d',' ',':',
+  ' ','S','h','o','w',' ','d','e','b','u','g',' ','i','n','f',
+  'o',#000,'*','*','2','*','_','w',' ',':',' ','S','h','o','w',
+  ' ','w','a','r','n','i','n','g','s',' ',' ',' ',' ',' ',' ',
+  ' ',' ',' ',' ',' ',' ',' ',' ',' ','u',' ',':',' ','S','h',
+  'o','w',' ','u','s','e','d',' ','f','i','l','e','s',#000,'*',
+  '*','2','*','_','n',' ',':',' ','S','h','o','w',' ','n','o',
+  't','e','s',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',
+  ' ',' ',' ',' ',' ',' ','t',' ',':',' ','S','h','o','w',' ',
+  't','r','i','e','d',' ','f','i','l','e','s',#000,'*','*','2',
+  '*','_','h',' ',':',' ','S','h','o','w',' ','h','i','n','t',
+  's',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',
+  ' ',' ',' ',' ','m',' ',':',' ','S','h','o','w',' ','d','e',
+  'f','i','n','e','d',' ','m','a','c','r','o','s',#000,'*','*',
+  '2','*','_','i',' ',':',' ','S','h','o','w',' ','g','e','n',
+  'e','r','a','l',' ','i','n','f','o',' ',' ',' ',' ',' ',' ',
+  ' ',' ',' ',' ',' ','p',' ',':',' ','S','h','o','w',' ','c',
+  'o','m','p','i','l','e','d',' ','p','r','o','c','e','d','u',
+  'r','e','s',#000,'*','*','2','*','_','l',' ',':',' ','S','h',
+  'o','w',' ','l','i','n','e','n','u','m','b','e','r','s',' ',
+  ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ','c',' ',':',' ',
+  'S','h','o','w',' ','c','o','n','d','i','t','i','o','n','a',
+  'l','s',#000,'*','*','2','*','_','a',' ',':',' ','S','h','o',
+  'w',' ','e','v','e','r','y','t','h','i','n','g',' ',' ',' ',
+  ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ','0',' ',':',' ','S',
+  'h','o','w',' ','n','o','t','h','i','n','g',' ','(','e','x',
+  'c','e','p','t',' ','e','r','r','o','r','s',')',#000,'*','*',
+  '1','X','_','e','x','e','c','u','t','a','b','l','e',' ','o',
+  'p','t','i','o','n','s',#000,'*','L','2','X','c','_','l','i',
+  'n','k',' ','w','i','t','h',' ','t','h','e',' ','c',' ','l',
+  'i','b','r','a','r','y',#000,'*','*','2','X','s','_','s','t',
+  'r','i','p',' ','a','l','l',' ','s','y','m','b','o','l','s',
+  ' ','f','r','o','m',' ','e','x','e','c','u','t','a','b','l',
+  'e',#000,'*','*','0','*','_','P','r','o','c','e','s','s','o',
+  'r',' ','s','p','e','c','i','f','i','c',' ','o','p','t','i',
+  'o','n','s',':',#000,'3','*','1','A','_','o','u','t','p','u',
+  't',' ','f','o','r','m','a','t',#000,'3','*','2','A','a','t',
+  't','_','A','T','&','T',' ','a','s','s','e','m','b','l','e',
+  'r',#000,'3','*','2','A','o','_','c','o','f','f',' ','f','i',
+  'l','e',' ','u','s','i','n','g',' ','G','N','U',' ','A','S',
+  #000,'3','*','2','A','o','b','j','_','O','M','F',' ','f','i',
+  'l','e',' ','u','s','i','n','g',' ','N','A','S','M',#000,'3',
+  '*','2','A','n','a','s','m','_','c','o','f','f',' ','f','i',
+  'l','e',' ','u','s','i','n','g',' ','N','A','S','M',#000,'3',
+  '*','2','A','m','a','s','m','_','a','s','s','e','m','b','l',
+  'e','r',' ','f','o','r',' ','t','h','e',' ','M','i','c','r',
+  'o','s','o','f','t','/','B','o','r','l','a','n','d','/','W',
+  'a','t','c','o','m',' ','a','s','s','e','m','b','l','e','r',
+  #000,'3','*','1','R','_','a','s','s','e','m','b','l','e','r',
+  ' ','r','e','a','d','i','n','g',' ','s','t','y','l','e',#000,
+  '3','*','2','R','a','t','t','_','r','e','a','d',' ','A','T',
+  '&','T',' ','s','t','y','l','e',' ','a','s','s','e','m','b',
+  'l','e','r',#000,'3','*','2','R','i','n','t','e','l','_','r',
+  'e','a','d',' ','I','n','t','e','l',' ','s','t','y','l','e',
+  ' ','a','s','s','e','m','b','l','e','r',#000,'3','*','2','R',
+  'd','i','r','e','c','t','_','c','o','p','y',' ','a','s','s',
+  'e','m','b','l','e','r',' ','t','e','x','t',' ','d','i','r',
+  'e','c','t','l','y',' ','t','o',' ','a','s','s','e','m','b',
+  'l','e','r',' ','f','i','l','e',#000,'3','*','1','O','_','o',
+  'p','t','i','m','i','z','a','t','i','o','n','s',#000,'3','*',
+  '2','O','a','_','s','i','m','p','l','e',' ','o','p','t','i',
+  'm','i','z','a','t','i','o','n','s',#000,'3','*','2','O','g',
+  '_','o','p','t','i','m','i','z','e',' ','f','o','r',' ','s',
+  'i','z','e',#000,'3','*','2','O','G','_','o','p','t','i','m',
+  'i','z','e',' ','f','o','r',' ','t','i','m','e',#000,'3','*',
+  '2','O','x','_','o','p','t','i','m','i','z','e',' ','m','a',
+  'x','i','m','u','m',#000,'3','*','2','O','z','_','u','n','c',
+  'e','r','t','a','i','n',' ','o','p','t','i','m','i','z','e',
+  's',' ','(','s','e','e',' ','d','o','c','s',')',#000,'3','*',
+  '2','O','2','_','o','p','t','i','m','i','z','e',' ','f','o',
+  'r',' ','P','e','n','t','i','u','m',' ','I','I',' ','(','t',
+  'm',')',#000,'3','*','2','O','3','_','o','p','t','i','m','i',
+  'z','e',' ','f','o','r',' ','i','3','8','6',#000,'3','*','2',
+  'O','4','_','o','p','t','i','m','i','z','e',' ','f','o','r',
+  ' ','i','4','8','6',#000,'3','*','2','O','5','_','o','p','t',
+  'i','m','i','z','e',' ','f','o','r',' ','P','e','n','t','i',
+  'u','m',' ','(','t','m',')',#000,'3','*','2','O','6','_','o',
+  'p','t','i','m','i','z','a','t','i','o','n','s',' ','f','o',
+  'r',' ','P','e','n','t','i','u','m','P','r','o',' ','(','t',
+  'm',')',#000,'6','*','1','A','_','o','u','t','p','u','t',' ',
+  'f','o','r','m','a','t',#000,'6','*','2','A','g','a','s','_',
+  'G','N','U',' ','M','o','t','o','r','o','l','a',' ','a','s',
+  's','e','m','b','l','e','r',#000,'6','*','2','A','o','_','U',
+  'N','I','X',' ','o','-','f','i','l','e',#000,'6','*','2','A',
+  'm','_','S','t','a','n','d','a','r','d',' ','M','o','t','o',
+  'r','o','l','a',' ','a','s','s','e','m','b','l','e','r',#000,
+  '6','*','2','A','i','_','M','I','T',' ','S','y','n','t','a',
+  'x',' ','(','o','l','d',' ','G','A','S',')',#000,'6','*','1',
+  'O','_','o','p','t','i','m','i','z','a','t','i','o','n','s',
+  #000,'6','*','2','O','a','_','s','i','m','p','l','e',' ','o',
+  'p','t','i','m','i','z','a','t','i','o','n','s',#000,'6','*',
+  '2','O','g','_','o','p','t','i','m','i','z','e',' ','f','o',
+  'r',' ','s','i','z','e',#000,'6','*','2','O','G','_','o','p',
+  't','i','m','i','z','e',' ','f','o','r',' ','t','i','m','e',
+  #000,'6','*','2','O','x','_','o','p','t','i','m','i','z','e',
+  ' ','m','a','x','i','m','u','m',#000,'6','*','2','O','2','_',
+  't','a','r','g','e','t',' ','i','s',' ','a',' ','M','C','6',
+  '8','0','2','0','+',' ','p','r','o','c','e','s','s','o','r',
+  #000,'*','*','1','*','_',#000,'*','*','1','?','_','s','h','o',
+  'w','s',' ','t','h','i','s',' ','h','e','l','p',#000,'*','*',
+  '1','h','_','s','h','o','w','s',' ','t','h','i','s',' ','h',
+  'e','l','p',' ','w','i','t','h','o','u','t',' ','w','a','i',
+  't','i','n','g',#000);

compiler/opts386.pas

@@ -0,0 +1,212 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl, Pierre Muller
+
+    interprets the commandline options which are i386 specific
+
+    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 opts386;
+interface
+
+uses
+  options;
+
+type
+  poption386=^toption386;
+  toption386=object(toption)
+    procedure interpret_proc_specific_options(const opt:string);virtual;
+  end;
+
+implementation
+
+uses
+  globals;
+
+procedure toption386.interpret_proc_specific_options(const opt:string);
+var
+  j : longint;
+begin
+  case opt[2] of
+   'A' : begin
+           if copy(opt,3,length(opt)-2)='o' then
+            begin
+              output_format:=of_o;
+              assem_need_external_list:=false;
+            end
+           else
+            if copy(opt,3,length(opt)-2)='masm' then
+             begin
+               output_format:=of_masm;
+               assem_need_external_list:=true;
+             end
+           else
+            if copy(opt,3,length(opt)-2)='att' then
+             begin
+               output_format:=of_att;
+               assem_need_external_list:=false;
+             end
+           else
+            if copy(opt,3,length(opt)-2)='win32' then
+             begin
+               output_format:=of_win32;
+               assem_need_external_list:=false;
+             end
+           else
+            if copy(opt,3,length(opt)-2)='obj' then
+             begin
+               output_format:=of_obj;
+               assem_need_external_list:=true;
+             end
+           else
+            if copy(opt,3,length(opt)-2)='nasm' then
+             begin
+               output_format:=of_nasm;
+               assem_need_external_list:=true;
+             end
+           else
+            IllegalPara(opt);
+         end;
+   'O' : begin
+           for j:=3 to length(opt) do
+           case opt[j] of
+            '-' : initswitches:=initswitches-[cs_optimize,cs_maxoptimieren,cs_littlesize];
+            'a' : initswitches:=initswitches+[cs_optimize];
+            'g' : initswitches:=initswitches+[cs_littlesize];
+            'G' : initswitches:=initswitches-[cs_littlesize];
+            'x' : initswitches:=initswitches+[cs_optimize,cs_maxoptimieren];
+            'z' : initswitches:=initswitches+[cs_optimize,cs_uncertainopts];
+            '2' : opt_processors:=pentium2;
+            '3' : opt_processors:=globals.i386;
+            '4' : opt_processors:=i486;
+            '5' : opt_processors:=pentium;
+            '6' : opt_processors:=pentiumpro;
+            else IllegalPara(opt);
+            end;
+          end;
+    'R' : begin
+            if copy(opt,3,length(opt)-2)='att' then
+             aktasmmode:=I386_ATT
+            else
+             if copy(opt,3,length(opt)-2)='intel' then
+              aktasmmode:=I386_INTEL
+            else
+             if copy(opt,3,length(opt)-2)='direct' then
+              aktasmmode:=I386_DIRECT
+            else
+             IllegalPara(opt);
+          end;
+  else IllegalPara(opt);
+  end;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:14  root
+  Initial revision
+
+  Revision 1.17  1998/03/10 01:17:21  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.16  1998/03/06 01:09:00  peter
+    * removed the conflicts that had occured
+
+  Revision 1.15  1998/03/06 00:52:30  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.14  1998/03/05 22:41:52  florian
+    + missing constructor to options object added
+
+  Revision 1.13  1998/03/05 02:44:14  peter
+    * options cleanup and use of .msg file
+
+  Revision 1.12  1998/03/04 17:33:47  michael
+  + Changed ifdef FPK to ifdef FPC
+
+  Revision 1.11  1998/03/02 21:21:39  jonas
+    + added support for uncertain optimizations
+
+  Revision 1.10  1998/03/02 01:48:47  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.9  1998/02/22 23:03:20  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.8  1998/02/13 10:35:12  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.7  1998/02/12 11:50:15  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.6  1998/02/08 23:56:55  peter
+    + -O- to turn off optimizes
+
+  Revision 1.5  1998/01/23 17:12:14  pierre
+    * added some improvements for as and ld :
+      - doserror and dosexitcode treated separately
+      - PATH searched if doserror=2
+    + start of long and ansi string (far from complete)
+      in conditionnal UseLongString and UseAnsiString
+    * options.pas cleaned (some variables shifted to globals)gl
+
+  Revision 1.4  1998/01/07 00:16:54  michael
+  Restored released version (plus fixes) as current
+
+  Revision 1.2  1997/12/15 09:11:29  florian
+    + again opts386.pas commited (there was an error)
+
+  Revision 1.1.1.1  1997/11/27 08:32:57  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
+
+  History:
+       8th october 1997:
+         * started from options.pas (FK)
+       23th november 1997:
+         + added -R option for different assembler reading style (PM)
+}

compiler/opts68k.pas

@@ -0,0 +1,176 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl, Pierre Muller
+
+    interprets the commandline options which are m68k specific
+
+    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 opts68k;
+interface
+
+uses
+  options;
+
+type
+  poption68k=^toption68k;
+  toption68k=object(toption)
+    procedure interpret_proc_specific_options(const opt:string);virtual;
+  end;
+
+implementation
+
+uses
+  globals;
+
+procedure toption68k.interpret_proc_specific_options(const opt:string);
+var
+  j : longint;
+begin
+  case opt[2] of
+   'A' : begin
+           if copy(opt,3,length(opt)-2)='o' then
+            begin
+              output_format:=of_o;
+              assem_need_external_list := false;
+            end
+           else
+            if copy(opt,3,length(opt)-2)='m' then
+             begin
+               output_format:=of_mot;
+               assem_need_external_list := true;
+             end
+           else
+            if copy(opt,3,length(opt)-2)='i' then
+             begin
+               output_format:=of_mit;
+               assem_need_external_list := false;
+             end
+           else
+            if copy(opt,3,length(opt)-2)='gas' then
+             begin
+               output_format:=of_gas;
+               assem_need_external_list := false;
+             end
+           else
+            IllegalPara(opt);
+         end;
+   'O' : begin
+           for j:=3 to length(opt) do
+            case opt[j] of
+             '-' : initswitches:=initswitches-[cs_optimize,cs_maxoptimieren,cs_littlesize];
+             'a' : initswitches:=initswitches+[cs_optimize];
+             'g' : initswitches:=initswitches+[cs_littlesize];
+             'G' : initswitches:=initswitches-[cs_littlesize];
+             'x' : initswitches:=initswitches+[cs_optimize,
+                    cs_maxoptimieren];
+             '2' : opt_processors := MC68020;
+             else
+              IllegalPara(opt);
+             end;
+         end;
+  else IllegalPara(opt);
+  end;
+end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:16  root
+  Initial revision
+
+  Revision 1.13  1998/03/13 22:45:58  florian
+    * small bug fixes applied
+
+  Revision 1.12  1998/03/10 16:27:39  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:21  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/06 00:52:31  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.9  1998/03/05 02:44:15  peter
+    * options cleanup and use of .msg file
+
+  Revision 1.8  1998/03/04 17:33:48  michael
+  + Changed ifdef FPK to ifdef FPC
+
+  Revision 1.7  1998/03/02 01:48:47  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/22 23:03:20  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.5  1998/02/21 03:34:27  carl
+    + mit asm syntax support
+
+  Revision 1.4  1998/02/13 10:35:12  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.3  1998/02/12 11:50:15  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.2  1998/01/09 19:22:03  carl
+  * externals are now generated as appropriate
+
+  Revision 1.1.1.1  1997/11/27 08:32:57  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
+
+  History:
+      4th cotober 1997:
+         + copied stuff from opts386.pas and started unit (CEC)
+      8th cotober 1997:
+         * new command line options management (FK)
+}
+

compiler/os2_targ.pas

@@ -0,0 +1,375 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Daniel Mantione
+    Portions Copyright (c) 1992-96 Eberhard Mattes
+
+    Unit to write out import libraries and def files for OS/2
+
+    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.
+
+ ****************************************************************************
+}
+{
+   A lot of code in this unit has been ported from C to Pascal from the
+   emximp utility, part of the EMX development system. Emximp is copyrighted
+   by Eberhard Mattes. Note: Eberhard doesn't know much about the Pascal
+   port, please send questions to Daniel Mantione
+   <[email protected]>.
+}
+unit os2_targ;
+
+interface
+
+uses import;
+
+type
+  pimportlibos2=^timportlibos2;
+  timportlibos2=object(timportlib)
+    procedure preparelib(const s:string);virtual;
+    procedure importprocedure(const func,module:string;index:longint;const name:string);virtual;
+    procedure generatelib;virtual;
+  end;
+
+procedure write_def_file;
+
+{***************************************************************************}
+
+{***************************************************************************}
+
+implementation
+
+uses    dos,strings,globals,link,files;
+
+const   profile_flag:boolean=false;
+
+const   n_ext   = 1;
+        n_abs   = 2;
+        n_text  = 4;
+        n_data  = 6;
+        n_bss   = 8;
+        n_imp1  = $68;
+        n_imp2  = $6a;
+
+type    reloc=packed record     {This is the layout of a relocation table
+                                 entry.}
+            address:longint;    {Fixup location}
+            remaining:longint;
+            {Meaning of bits for remaining:
+             0..23:              Symbol number or segment
+             24:                 Self-relative fixup if non-zero
+             25..26:             Fixup size (0: 1 byte, 1: 2, 2: 4 bytes)
+             27:                 Reference to symbol or segment
+             28..31              Not used}
+        end;
+
+        nlist=packed record     {This is the layout of a symbol table entry.}
+            strofs:longint;     {Offset in string table}
+            typ:byte;           {Type of the symbol}
+            other:byte;         {Other information}
+            desc:word;          {More information}
+            value:longint;      {Value (address)}
+        end;
+
+        a_out_header=packed record
+            magic:word;         {Magic word, must be $0107}
+            machtype:byte;      {Machine type}
+            flags:byte;         {Flags}
+            text_size:longint;  {Length of text, in bytes}
+            data_size:longint;  {Length of initialized data, in bytes}
+            bss_size:longint;   {Length of uninitialized data, in bytes}
+            sym_size:longint;   {Length of symbol table, in bytes}
+            entry:longint;      {Start address (entry point)}
+            trsize:longint;     {Length of relocation info for text, bytes}
+            drsize:longint;     {Length of relocation info for data, bytes}
+        end;
+
+        ar_hdr=packed record
+            ar_name:array[0..15] of char;
+            ar_date:array[0..11] of char;
+            ar_uid:array[0..5] of char;
+            ar_gid:array[0..5] of char;
+            ar_mode:array[0..7] of char;
+            ar_size:array[0..9] of char;
+            ar_fmag:array[0..1] of char;
+        end;
+
+var aout_str_size:longint;
+    aout_str_tab:array[0..2047] of byte;
+    aout_sym_count:longint;
+    aout_sym_tab:array[0..5] of nlist;
+
+    aout_text:array[0..63] of byte;
+    aout_text_size:longint;
+
+    aout_treloc_tab:array[0..1] of reloc;
+    aout_treloc_count:longint;
+
+    aout_size:longint;
+    seq_no:longint;
+
+    ar_member_size:longint;
+
+    out_file:file;
+
+procedure write_ar(const name:string;size:longint);
+
+var ar:ar_hdr;
+    time:datetime;
+    dummy:word;
+    numtime:longint;
+    tmp:string[19];
+
+
+begin
+    ar_member_size:=size;
+    fillchar(ar.ar_name,sizeof(ar.ar_name),' ');
+    move(name[1],ar.ar_name,length(name));
+    getdate(time.year,time.month,time.day,dummy);
+    gettime(time.hour,time.min,time.sec,dummy);
+    packtime(time,numtime);
+    str(numtime,tmp);
+    fillchar(ar.ar_date,sizeof(ar.ar_date),' ');
+    move(tmp[1],ar.ar_date,length(tmp));
+    ar.ar_uid:='0     ';
+    ar.ar_gid:='0     ';
+    ar.ar_mode:='100666'#0#0;
+    str(size,tmp);
+    fillchar(ar.ar_size,sizeof(ar.ar_size),' ');
+    move(tmp[1],ar.ar_size,length(tmp));
+    ar.ar_fmag:='`'#10;
+    blockwrite(out_file,ar,sizeof(ar));
+end;
+
+procedure finish_ar;
+
+var a:byte;
+
+begin
+    a:=0;
+    if odd(ar_member_size) then
+        blockwrite(out_file,a,1);
+end;
+
+procedure aout_init;
+
+begin
+  aout_str_size:=sizeof(longint);
+  aout_sym_count:=0;
+  aout_text_size:=0;
+  aout_treloc_count:=0;
+end;
+
+function aout_sym(const name:string;typ,other:byte;desc:word;
+                  value:longint):longint;
+
+begin
+    if aout_str_size+length(name)+1>sizeof(aout_str_tab) then
+        runerror($da);
+    if aout_sym_count>=sizeof(aout_sym_tab) div sizeof(aout_sym_tab[0]) then
+        runerror($da);
+    aout_sym_tab[aout_sym_count].strofs:=aout_str_size;
+    aout_sym_tab[aout_sym_count].typ:=typ;
+    aout_sym_tab[aout_sym_count].other:=other;
+    aout_sym_tab[aout_sym_count].desc:=desc;
+    aout_sym_tab[aout_sym_count].value:=value;
+    strPcopy(@aout_str_tab[aout_str_size],name);
+    aout_str_size:=aout_str_size+length(name)+1;
+    aout_sym:=aout_sym_count;
+    inc(aout_sym_count);
+end;
+
+procedure aout_text_byte(b:byte);
+
+begin
+    if aout_text_size>=sizeof(aout_text) then
+        runerror($da);
+    aout_text[aout_text_size]:=b;
+    inc(aout_text_size);
+end;
+
+procedure aout_text_dword(d:longint);
+
+type li_ar=array[0..3] of byte;
+
+begin
+    aout_text_byte(li_ar(d)[0]);
+    aout_text_byte(li_ar(d)[1]);
+    aout_text_byte(li_ar(d)[2]);
+    aout_text_byte(li_ar(d)[3]);
+end;
+
+procedure aout_treloc(address,symbolnum,pcrel,len,ext:longint);
+
+begin
+    if aout_treloc_count>=sizeof(aout_treloc_tab) div sizeof(reloc) then
+        runerror($da);
+    aout_treloc_tab[aout_treloc_count].address:=address;
+    aout_treloc_tab[aout_treloc_count].remaining:=symbolnum+pcrel shl 24+
+     len shl 25+ext shl 27;
+    inc(aout_treloc_count);
+end;
+
+procedure aout_finish;
+
+begin
+    while (aout_text_size and 3)<>0 do
+        aout_text_byte ($90);
+    aout_size:=sizeof(a_out_header)+aout_text_size+aout_treloc_count*
+     sizeof(reloc)+aout_sym_count*sizeof(aout_sym_tab[0])+aout_str_size;
+end;
+
+procedure aout_write;
+
+var ao:a_out_header;
+
+begin
+    ao.magic:=$0107;
+    ao.machtype:=0;
+    ao.flags:=0;
+    ao.text_size:=aout_text_size;
+    ao.data_size:=0;
+    ao.bss_size:=0;
+    ao.sym_size:=aout_sym_count*sizeof(aout_sym_tab[0]);
+    ao.entry:=0;
+    ao.trsize:=aout_treloc_count*sizeof(reloc);
+    ao.drsize:=0;
+    blockwrite(out_file,ao,sizeof(ao));
+    blockwrite(out_file,aout_text,aout_text_size);
+    blockwrite(out_file,aout_treloc_tab,sizeof(reloc)*aout_treloc_count);
+    blockwrite(out_file,aout_sym_tab,sizeof(aout_sym_tab[0])*aout_sym_count);
+    longint((@aout_str_tab)^):=aout_str_size;
+    blockwrite(out_file,aout_str_tab,aout_str_size);
+end;
+
+procedure timportlibos2.preparelib(const s:string);
+
+{This code triggers a lot of bugs in the compiler.
+const   armag='!<arch>'#10;
+        ar_magic:array[1..length(armag)] of char=armag;}
+const   ar_magic:array[1..8] of char='!<arch>'#10;
+
+begin
+    seq_no:=1;
+    Linker.AddLibraryFile(s+'.dll');
+    current_module^.linkofiles.insert(s+'.dll');
+    assign(out_file,s+'.ao2');
+    rewrite(out_file,1);
+    blockwrite(out_file,ar_magic,sizeof(ar_magic));
+end;
+
+procedure timportlibos2.importprocedure(const func,module:string;index:longint;const name:string);
+{func       = Name of function to import.
+ module     = Name of DLL to import from.
+ index      = Index of function in DLL. Use 0 to import by name.
+ name       = Name of function in DLL. Ignored when index=0;}
+var tmp1,tmp2,tmp3:string;
+    sym_mcount,sym_entry,sym_import:longint;
+    fixup_mcount,fixup_import:longint;
+begin
+    aout_init;
+    tmp2:=func;
+    if profile_flag and not (copy(func,1,4)='_16_') then
+        begin
+            sym_entry:=aout_sym(func,n_text+n_ext,0,0,aout_text_size);
+            sym_mcount:=aout_sym('__mcount',n_ext,0,0,0);
+            {Use, say, "_$U_DosRead" for "DosRead" to import the
+             non-profiled function.}
+            tmp2:='__$U_'+func;
+            sym_import:=aout_sym(tmp2,n_ext,0,0,0);
+            aout_text_byte($55);    {push ebp}
+            aout_text_byte($89);    {mov ebp, esp}
+            aout_text_byte($e5);
+            aout_text_byte($e8);    {call _mcount}
+            fixup_mcount:=aout_text_size;
+            aout_text_dword(0-(aout_text_size+4));
+            aout_text_byte($5d);    {pop ebp}
+            aout_text_byte($e9);    {jmp _$U_DosRead}
+            fixup_import:=aout_text_size;
+            aout_text_dword(0-(aout_text_size+4));
+
+            aout_treloc(fixup_mcount,sym_mcount,1,2,1);
+            aout_treloc (fixup_import, sym_import,1,2,1);
+        end;
+    str(seq_no,tmp1);
+    tmp1:='IMPORT#'+tmp1;
+    if name='' then
+        begin
+            str(index,tmp3);
+            tmp3:=func+'='+module+'.'+tmp3;
+        end
+    else
+        tmp3:=func+'='+module+'.'+name;
+    aout_sym(tmp2,n_imp1+n_ext,0,0,0);
+    aout_sym(tmp3,n_imp2+n_ext,0,0,0);
+    aout_finish;
+    write_ar(tmp1,aout_size);
+    aout_write;
+    finish_ar;
+    inc(seq_no);
+end;
+
+procedure timportlibos2.generatelib;
+
+begin
+    close(out_file);
+end;
+
+
+procedure write_def_file;
+begin
+   assign(deffile,inputdir+inputfile+'.DEF');
+   {$I+}
+    rewrite(deffile);
+   {$I-}
+   if ioresult=0 then
+    begin
+      write(deffile,'NAME '+inputfile);
+      if genpm then
+        write(deffile,' WINDOWAPI');
+      writeln(deffile,#13#10#13#10'PROTMODE'#13#10);
+      writeln(deffile,'DESCRIPTION '+''''+description+''''#13#10);
+      writeln(deffile,'DATA'#9'MULTIPLE'#13#10);
+      writeln(deffile,'STACKSIZE'#9+tostr(stacksize));
+      writeln(deffile,'HEAPSIZE'#9+tostr(heapsize)+#13#10);
+      write(deffile,'EXPORTS');
+    end
+   else
+    gendeffile:=false;
+end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.15  1998/03/10 01:17:21  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.14  1998/03/02 23:08:41  florian
+    * the concatcopy bug removed (solves problems when compilg sysatari!)
+
+  Revision 1.13  1998/03/02 13:38:40  peter
+    + importlib object
+    * doesn't crash on a systemunit anymore
+    * updated makefile and depend
+
+  Revision 1.11  1998/02/28 00:20:27  florian
+    * more changes to get import libs for Win32 working
+
+}

compiler/parser.pas

@@ -0,0 +1,885 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl
+
+    This unit does the parsing process
+
+    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.
+
+ ****************************************************************************
+}
+{$ifdef tp}
+  {$E+,N+,D+,F+}
+{$endif}
+unit parser;
+
+  interface
+
+    procedure compile(const filename:string;compile_system:boolean);
+    procedure initparser;
+
+  implementation
+
+    uses
+       dos,objects,cobjects,globals,scanner,systems,symtable,tree,aasm,
+       types,strings,pass_1,hcodegen,files,verbose,script,import
+{$ifdef i386}
+       ,i386
+       ,cgi386
+       ,cgai386
+       ,tgeni386
+       ,aopt386
+{$endif i386}
+{$ifdef m68k}
+        ,m68k
+        ,cg68k
+        ,tgen68k
+        ,cga68k
+{$endif m68k}
+       { parser units }
+       ,pbase,pmodules,pdecl,
+       { assembling & linking }
+       assemble,
+       link;
+
+  { dummy variable for search when calling exec }
+  var
+     file_found : boolean;
+
+    procedure readconstdefs;
+
+      begin
+         s32bitdef:=porddef(globaldef('longint'));
+         u32bitdef:=porddef(globaldef('ulong'));
+         cstringdef:=pstringdef(globaldef('string'));
+{$ifdef UseLongString}
+         clongstringdef:=pstringdef(globaldef('longstring'));
+{$endif UseLongString}
+{$ifdef UseAnsiString}
+         cansistringdef:=pstringdef(globaldef('ansistring'));
+{$endif UseAnsiString}
+         cchardef:=porddef(globaldef('char'));
+{$ifdef i386}
+         c64floatdef:=pfloatdef(globaldef('s64real'));
+{$endif}
+{$ifdef m68k}
+         c64floatdef:=pfloatdef(globaldef('s32real'));
+{$endif m68k}
+         s80floatdef:=pfloatdef(globaldef('s80real'));
+         s32fixeddef:=pfloatdef(globaldef('cs32fixed'));
+         voiddef:=porddef(globaldef('void'));
+         u8bitdef:=porddef(globaldef('byte'));
+         u16bitdef:=porddef(globaldef('word'));
+         booldef:=porddef(globaldef('boolean'));
+         voidpointerdef:=ppointerdef(globaldef('void_pointer'));
+         cfiledef:=pfiledef(globaldef('file'));
+      end;
+
+    procedure initparser;
+
+      begin
+         forwardsallowed:=false;
+
+         { ^M means a string or a char, because we don't parse a }
+         { type declaration                                      }
+         parse_types:=false;
+
+         { we didn't parse a object or class declaration }
+         { and no function header                        }
+         testcurobject:=0;
+
+         { create error defintion }
+         generrordef:=new(perrordef,init);
+
+         symtablestack:=nil;
+
+         { a long time, this was forgotten }
+         aktprocsym:=nil;
+
+         current_module:=nil;
+
+         loaded_units.init;
+
+         usedunits.init;
+      end;
+
+    { moved out to save stack }
+    var
+       addparam : string;
+
+    procedure compile(const filename:string;compile_system:boolean);
+      var
+         hp : pmodule;
+         comp_unit : boolean;
+
+         { some variables to save the compiler state }
+         oldtoken : ttoken;
+         oldpattern : stringid;
+
+         oldpreprocstack : ppreprocstack;
+         oldorgpattern,oldprocprefix : string;
+         oldparse_types : boolean;
+         oldinputbuffer : pchar;
+         oldinputpointer : longint;
+         olds_point,oldparse_only : boolean;
+         oldc : char;
+         oldcomment_level : word;
+
+         oldimports,oldexports,oldresource,
+         oldbsssegment,olddatasegment,oldcodesegment,
+         oldexprasmlist,olddebuglist,
+         oldinternals,oldexternals,oldconsts : paasmoutput;
+
+
+         oldnextlabelnr : longint;
+
+         oldswitches : Tcswitches;
+         oldmacros,oldrefsymtable,oldsymtablestack : psymtable;
+
+
+      procedure def_macro(const s : string);
+
+        var
+          mac : pmacrosym;
+
+        begin
+           mac:=pmacrosym(macros^.search(s));
+           if mac=nil then
+             begin
+               mac:=new(pmacrosym,init(s));
+               Message1(parser_m_macro_defined,mac^.name);
+               macros^.insert(mac);
+             end;
+           mac^.defined:=true;
+        end;
+
+      procedure set_macro(const s : string;value : string);
+
+        var
+          mac : pmacrosym;
+
+        begin
+           mac:=pmacrosym(macros^.search(s));
+           if mac=nil then
+             begin
+               mac:=new(pmacrosym,init(s));
+               macros^.insert(mac);
+             end
+           else
+             begin
+                if assigned(mac^.buftext) then
+                  freemem(mac^.buftext,mac^.buflen);
+             end;
+           Message2(parser_m_macro_set_to,mac^.name,value);
+           mac^.buflen:=length(value);
+           getmem(mac^.buftext,mac^.buflen);
+           move(value[1],mac^.buftext^,mac^.buflen);
+           mac^.defined:=true;
+        end;
+
+      procedure define_macros;
+
+        var
+           hp : pstring_item;
+
+        begin
+           hp:=pstring_item(commandlinedefines.first);
+           while assigned(hp) do
+             begin
+               def_macro(hp^.str^);
+               hp:=pstring_item(hp^.next);
+             end;
+
+           { set macros for version checking }
+           set_macro('FPC_VERSION',version_nr);
+           set_macro('FPC_RELEASE',release_nr);
+           set_macro('FPC_PATCH',patch_nr);
+        end;
+
+      var
+         a : PAsmFile;
+         g : file;
+         ftime : longint;
+      label
+         done;
+
+      begin {compile}
+         inc(compile_level);
+         { save old state }
+
+         { save symtable state }
+         oldsymtablestack:=symtablestack;
+         symtablestack:=nil;
+         oldrefsymtable:=refsymtable;
+         refsymtable:=nil;
+         oldprocprefix:=procprefix;
+
+         { a long time, this was only in init_parser
+           but it should be reset to zero for each module }
+         aktprocsym:=nil;
+
+         { first, we assume a program }
+         if not(assigned(current_module)) then
+           begin
+{!!!}
+              current_module:=new(pmodule,init(filename,false));
+              main_module:=current_module;
+           end;
+         { reset flags }
+         current_module^.flags:=0;
+         { ... and crc }
+         current_module^.crc:=0;
+
+         { save scanner state }
+         oldmacros:=macros;
+         oldpattern:=pattern;
+         oldtoken:=token;
+         oldorgpattern:=orgpattern;
+         oldparse_types:=parse_types;
+         oldpreprocstack:=preprocstack;
+
+         oldinputbuffer:=inputbuffer;
+         oldinputpointer:=inputpointer;
+         olds_point:=s_point;
+         oldc:=c;
+         oldcomment_level:=comment_level;
+
+         oldparse_only:=parse_only;
+
+         { save assembler lists }
+         olddatasegment:=datasegment;
+         oldbsssegment:=bsssegment;
+         oldcodesegment:=codesegment;
+         olddebuglist:=debuglist;
+         oldexternals:=externals;
+         oldinternals:=internals;
+         oldconsts:=consts;
+         oldexprasmlist:=exprasmlist;
+         oldimports:=importssection;
+         oldexports:=exportssection;
+         oldresource:=resourcesection;
+
+         oldswitches:=aktswitches;
+         oldnextlabelnr:=nextlabelnr;
+
+         Message1(parser_i_compiling,filename);
+
+         InitScanner(filename);
+
+         aktswitches:=initswitches;
+
+         { we need this to make the system unit }
+         if compile_system then
+          aktswitches:=aktswitches+[cs_compilesystem];
+
+         aktexprlevel:=initexprlevel;
+         aktpackrecords:=initpackrecords;
+
+         { init code generator for a new module }
+         codegen_newmodule;
+         macros:=new(psymtable,init(macrosymtable));
+
+         define_macros;
+
+         { startup scanner }
+         token:=yylex;
+
+         { init asm writing }
+         datasegment:=new(paasmoutput,init);
+         codesegment:=new(paasmoutput,init);
+         bsssegment:=new(paasmoutput,init);
+         debuglist:=new(paasmoutput,init);
+         externals:=new(paasmoutput,init);
+         internals:=new(paasmoutput,init);
+         consts:=new(paasmoutput,init);
+         importssection:=nil;
+         exportssection:=nil;
+         resourcesection:=nil;
+
+         { global switches are read, so further changes aren't allowed }
+         current_module^.in_main:=true;
+
+         { open assembler response }
+         if (compile_level=1) then
+          AsmRes.Init('ppas');
+
+         { if the current file isn't a system unit  }
+         { the the system unit will be loaded       }
+         if not(cs_compilesystem in aktswitches) then
+           begin
+              { should be done in unit system (changing the field system_unit)
+                                                                      FK
+              }
+              hp:=loadunit(upper(target_info.system_unit),true,true);
+              systemunit:=hp^.symtable;
+              readconstdefs;
+              { we could try to overload caret by default }
+              symtablestack:=systemunit;
+              { if POWER is defined in the RTL then use it for caret overloading }
+              getsym('POWER',false);
+              if assigned(srsym) and (srsym^.typ=procsym) and
+                 (overloaded_operators[CARET]=nil) then
+                overloaded_operators[CARET]:=pprocsym(srsym);
+           end
+         else
+           begin
+              { create definitions for constants }
+              registerdef:=false;
+              s32bitdef:=new(porddef,init(s32bit,$80000000,$7fffffff));
+              u32bitdef:=new(porddef,init(u32bit,0,$ffffffff));
+              cstringdef:=new(pstringdef,init(255));
+              { should we give a length to the default long and ansi string definition ?? }
+{$ifdef UseLongString}
+              clongstringdef:=new(pstringdef,longinit(-1));
+{$endif UseLongString}
+{$ifdef UseAnsiString}
+              cansistringdef:=new(pstringdef,ansiinit(-1));
+{$endif UseAnsiString}
+              cchardef:=new(porddef,init(uchar,0,255));
+{$ifdef i386}
+              c64floatdef:=new(pfloatdef,init(s64real));
+              s80floatdef:=new(pfloatdef,init(s80real));
+{$endif}
+{$ifdef m68k}
+              c64floatdef:=new(pfloatdef,init(s32real));
+              if (cs_fp_emulation in aktswitches) then
+               s80floatdef:=new(pfloatdef,init(s32real))
+              else
+               s80floatdef:=new(pfloatdef,init(s80real));
+{$endif}
+              s32fixeddef:=new(pfloatdef,init(f32bit));
+
+              { some other definitions }
+              voiddef:=new(porddef,init(uvoid,0,0));
+              u8bitdef:=new(porddef,init(u8bit,0,255));
+              u16bitdef:=new(porddef,init(u16bit,0,65535));
+              booldef:=new(porddef,init(bool8bit,0,1));
+              voidpointerdef:=new(ppointerdef,init(voiddef));
+              cfiledef:=new(pfiledef,init(ft_untyped,nil));
+              systemunit:=nil;
+           end;
+         registerdef:=true;
+
+         { current return type is void }
+         procinfo.retdef:=voiddef;
+
+         { reset lexical level }
+         lexlevel:=0;
+
+         { parse source }
+{***BUGFIX}
+         if (token=_UNIT) or (compile_level>1) then
+            begin
+                {If the compile level > 1 we get a nice "unit expected" error
+                 message if we are trying to use a program as unit.}
+                proc_unit;
+                if current_module^.compiled then
+                    goto done;
+                comp_unit:=true;
+            end
+         else
+           begin
+              proc_program(token=_LIBRARY);
+              comp_unit:=false;
+           end;
+
+         { Why? The definition of Pascal requires that everything
+           after 'end.' is ignored!
+         if not(cs_tp_compatible in aktswitches) then
+            consume(_EOF); }
+
+         if errorcount=0 then
+           begin
+             if current_module^.uses_imports then
+              importlib^.generatelib;
+
+             a:=new(PAsmFile,Init(filename));
+             a^.WriteAsmSource;
+             a^.DoAssemble;
+             dispose(a,Done);
+
+             { Check linking  => we are at first level in compile }
+             if (compile_level=1) then
+              begin
+	        if Linker.ExeName='' then
+                 Linker.SetFileName(FileName);
+                if (comp_unit) then
+                 begin
+                   Linker.Make_Library;
+                 end
+                else
+                 begin
+                   if (cs_no_linking in initswitches) then
+                    externlink:=true;
+                   Linker.Link;
+                 end;
+              end;
+           end
+         else
+           begin
+              Message1(unit_e_total_errors,tostr(errorcount));
+              Message(unit_f_errors_in_unit);
+           end;
+         { clear memory }
+{$ifdef Splitheap}
+         if testsplit then
+           begin
+           { temp heap should be empty after that !!!}
+           codegen_donemodule;
+           Releasetempheap;
+           end;
+         {else
+           codegen_donemodule;}
+{$endif Splitheap}
+         { restore old state }
+         { if already compiled jumps directly here }
+done:
+         { close trees }
+{$ifdef disposetree}
+         dispose(datasegment,Done);
+         dispose(codesegment,Done);
+         dispose(bsssegment,Done);
+         dispose(debuglist,Done);
+         dispose(externals,Done);
+         dispose(internals,Done);
+         dispose(consts,Done);
+{$endif}
+
+         { restore symtable state }
+{$ifdef UseBrowser}
+         if (compile_level>1) then
+{ we want to keep the current symtablestack }
+{$endif UseBrowser}
+           begin
+              refsymtable:=oldrefsymtable;
+              symtablestack:=oldsymtablestack;
+           end;
+
+         procprefix:=oldprocprefix;
+
+         { close the inputfiles }
+{$ifndef UseBrowser}
+         { but not if we want the names for the browser ! }
+         current_module^.sourcefiles.done;
+{$endif not UseBrowser}
+         { restore scanner state }
+         pattern:=oldpattern;
+         token:=oldtoken;
+         orgpattern:=oldorgpattern;
+         parse_types:=oldparse_types;
+
+         { call donescanner before restoring preprocstack, because }
+         { donescanner tests for a empty preprocstack              }
+         { and can also check for unused macros                    }
+         donescanner(current_module^.compiled);
+         dispose(macros,done);
+         macros:=oldmacros;
+
+
+         preprocstack:=oldpreprocstack;
+
+         aktswitches:=oldswitches;
+         inputbuffer:=oldinputbuffer;
+         inputpointer:=oldinputpointer;
+         s_point:=olds_point;
+         c:=oldc;
+         comment_level:=oldcomment_level;
+
+         parse_only:=oldparse_only;
+
+         { restore asmlists }
+         datasegment:=olddatasegment;
+         bsssegment:=oldbsssegment;
+         codesegment:=oldcodesegment;
+         debuglist:=olddebuglist;
+         externals:=oldexternals;
+         internals:=oldinternals;
+         importssection:=oldimports;
+         exportssection:=oldexports;
+         resourcesection:=oldresource;
+
+         nextlabelnr:=oldnextlabelnr;
+         exprasmlist:=oldexprasmlist;
+         consts:=oldconsts;
+
+         nextlabelnr:=oldnextlabelnr;
+
+         reset_gdb_info;
+         if (compile_level=1) then
+          begin
+            if (not AsmRes.Empty) then
+             begin
+               Message1(exec_i_closing_script,AsmRes.Fn);
+               AsmRes.WriteToDisk;
+             end;
+          end;
+         dec(compile_level);
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:12  root
+  Initial revision
+
+  Revision 1.60  1998/03/24 21:48:32  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.59  1998/03/20 23:31:33  florian
+    * bug0113 fixed
+    * problem with interdepened units fixed ("options.pas problem")
+    * two small extensions for future AMD 3D support
+
+  Revision 1.58  1998/03/13 22:45:58  florian
+    * small bug fixes applied
+
+  Revision 1.57  1998/03/10 17:19:29  peter
+    * fixed bug0108
+    * better linebreak scanning (concentrated in nextchar(), it supports
+      #10, #13, #10#13, #13#10
+
+  Revision 1.56  1998/03/10 16:27:40  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.55  1998/03/10 12:54:06  peter
+    * def_symbol renamed to def_macro and use it in defines_macros
+
+  Revision 1.54  1998/03/10 01:17:22  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.53  1998/03/06 00:52:34  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.52  1998/03/02 16:00:37  peter
+    * -Ch works again
+
+  Revision 1.51  1998/03/02 13:38:44  peter
+    + importlib object
+    * doesn't crash on a systemunit anymore
+    * updated makefile and depend
+
+  Revision 1.49  1998/02/28 00:20:31  florian
+    * more changes to get import libs for Win32 working
+
+  Revision 1.48  1998/02/27 22:27:56  florian
+    + win_targ unit
+    + support of sections
+    + new asmlists: sections, exports and resource
+
+  Revision 1.47  1998/02/24 10:29:17  peter
+    * -a works again
+
+  Revision 1.46  1998/02/24 00:19:14  peter
+    * makefile works again (btw. linux does like any char after a \ )
+    * removed circular unit with assemble and files
+    * fixed a sigsegv in pexpr
+    * pmodule init unit/program is the almost the same, merged them
+
+  Revision 1.45  1998/02/22 23:03:25  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.44  1998/02/19 00:11:04  peter
+    * fixed -g to work again
+    * fixed some typos with the scriptobject
+
+  Revision 1.43  1998/02/18 13:48:12  michael
+  + Implemented an OS independent AsmRes object.
+
+  Revision 1.42  1998/02/17 21:20:54  peter
+    + Script unit
+    + __EXIT is called again to exit a program
+    - target_info.link/assembler calls
+    * linking works again for dos
+    * optimized a few filehandling functions
+    * fixed stabs generation for procedures
+
+  Revision 1.41  1998/02/16 12:51:35  michael
+  + Implemented linker object
+
+  Revision 1.40  1998/02/15 21:16:25  peter
+    * all assembler outputs supported by assemblerobject
+    * cleanup with assembleroutputs, better .ascii generation
+    * help_constructor/destructor are now added to the externals
+    - generation of asmresponse is not outputformat depended
+
+  Revision 1.39  1998/02/14 01:45:26  peter
+    * more fixes
+    - pmode target is removed
+    - search_as_ld is removed, this is done in the link.pas/assemble.pas
+    + findexe() to search for an executable (linker,assembler,binder)
+
+  Revision 1.38  1998/02/13 22:26:33  peter
+    * fixed a few SigSegv's
+    * INIT$$ was not written for linux!
+    * assembling and linking works again for linux and dos
+    + assembler object, only attasmi3 supported yet
+    * restore pp.pas with AddPath etc.
+
+  Revision 1.37  1998/02/13 10:35:17  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.36  1998/02/12 17:19:12  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.35  1998/02/12 11:50:16  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.34  1998/02/02 11:47:36  pierre
+    + compilation stops at unit with error
+
+  Revision 1.33  1998/02/01 22:41:08  florian
+    * clean up
+    + system.assigned([class])
+    + system.assigned([class of xxxx])
+    * first fixes of as and is-operator
+
+  Revision 1.32  1998/01/30 17:31:23  pierre
+    * bug of cyclic symtablestack fixed
+
+  Revision 1.31  1998/01/29 12:13:21  michael
+  * fixed Typos for library making
+
+  Revision 1.30  1998/01/28 13:48:45  michael
+  + Initial implementation for making libs from within FPC. Not tested, as compiler does not run
+
+  Revision 1.29  1998/01/25 18:45:47  peter
+    + Search for as and ld at startup
+    + source_info works the same as target_info
+    + externlink allows only external linking
+
+  Revision 1.28  1998/01/23 21:14:59  carl
+    * RunError 105 (file not open) with -Agas switch fix
+
+  Revision 1.27  1998/01/23 17:55:11  michael
+  + Moved linking stage to it's own unit (link.pas)
+    Incorporated Pierres changes, but removed -E switch
+    switch for not linking is now -Cn instead of -E
+
+  Revision 1.26  1998/01/23 17:12:15  pierre
+    * added some improvements for as and ld :
+      - doserror and dosexitcode treated separately
+      - PATH searched if doserror=2
+    + start of long and ansi string (far from complete)
+      in conditionnal UseLongString and UseAnsiString
+    * options.pas cleaned (some variables shifted to globals)gl
+
+  Revision 1.25  1998/01/22 14:47:16  michael
+  + Reinstated linker options as -k option. How did they dissapear ?
+
+  Revision 1.24  1998/01/17 01:57:36  michael
+  + Start of shared library support. First working version.
+
+  Revision 1.23  1998/01/16 22:34:37  michael
+  * Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
+    in this compiler :)
+
+  Revision 1.22  1998/01/14 12:52:04  michael
+  - Removed the 'Assembled' line and replaced 'Calling Linker/assembler...'
+    with 'Assembling/linking...'. Too much verbosity when V_info is on.
+
+  Revision 1.21  1998/01/13 16:15:56  pierre
+    *  bug in interdependent units handling
+       - primary unit was not in loaded_units list
+       - current_module^.symtable was assigned too early
+       - donescanner must not call error if the compilation
+       of the unit was done at a higher level.
+
+  Revision 1.20  1998/01/11 10:54:22  florian
+    + generic library support
+
+  Revision 1.19  1998/01/11 04:17:11  carl
+  + correct heap and memory variables for m68k targets
+
+  Revision 1.18  1998/01/08 23:56:39  florian
+    * parser unit divided into several smaller units
+
+  Revision 1.17  1998/01/08 17:10:12  florian
+    * the name of the initialization part of a unit was sometimes written
+      in lower case
+
+  Revision 1.16  1998/01/07 00:16:56  michael
+  Restored released version (plus fixes) as current
+
+  Revision 1.13  1997/12/14 22:43:21  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.12  1997/12/12 13:28:31  florian
+  + version 0.99.0
+  * all WASM options changed into MASM
+  + -O2 for Pentium II optimizations
+
+  Revision 1.11  1997/12/10 23:07:21  florian
+  * bugs fixed: 12,38 (also m68k),39,40,41
+  + warning if a system unit is without -Us compiled
+  + warning if a method is virtual and private (was an error)
+  * some indentions changed
+  + factor does a better error recovering (omit some crashes)
+  + problem with @type(x) removed (crashed the compiler)
+
+  Revision 1.10  1997/12/09 13:50:36  carl
+  * bugfix of possible alignment problems with m68k
+  * bugfix of circular unit use -- could still give a stack overflow,
+    so changed to fatalerror instead.
+  * bugfix of nil procedural variables, fpc = @nil is illogical!
+    (if was reversed!)
+
+  Revision 1.9  1997/12/08 13:31:31  daniel
+  * File was in DOS format. Translated to Unix.
+
+  Revision 1.8  1997/12/08 10:01:08  pierre
+    * nil for a procvar const was not allowed (os2_targ.pas not compilable)
+    * bug in loadunit for units in implementation part already loaded
+      (crashed on dos_targ.pas, thanks to Daniel who permitted me
+      to find this bug out)
+
+  Revision 1.7  1997/12/04 17:47:50  carl
+   + renamed m68k units and refs to these units according to cpu rules.
+
+  Revision 1.6  1997/12/02 15:56:13  carl
+  * bugfix of postfixoperator with pd =nil
+  * bugfix of motorola instructions types for exit code.
+
+  Revision 1.5  1997/12/01 18:14:33  pierre
+      * fixes a bug in nasm output due to my previous changes
+
+  Revision 1.3  1997/11/28 18:14:40  pierre
+   working version with several bug fixes
+
+  Revision 1.2  1997/11/27 17:59:46  carl
+  * made it compile under BP (line too long errors)
+
+  Revision 1.1.1.1  1997/11/27 08:32:57  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
+
+
+
+  History (started with version 0.9.0):
+       5th november 1996:
+         * adapted to 0.9.0
+      25th november 1996:
+         * more stuff adapted
+       9th december 1996:
+         + support for different inline assemblers added (FK)
+      22th september:
+         + support for PACKED RECORD implemented (FK)
+      24th september:
+         + internal support of system.seg added (FK)
+         * system.ofs bug fixed (FK)
+         * problem with compiler switches solved (see also pass_1.pas) (FK)
+         * all aktswitch memory is now recoverd (see also scanner.pas) (FK)
+      24th september 1997:
+         * bug in ESI offset, pushed only if not nested, changed in cgi386.pas in v93 by (FK)
+           but forgotten here (PM)
+      25th september:
+         + parsing of open arrays implemented (FK)
+         + parsing of high and low implemented (FK)
+         + open array support also for proc vars added (FK)
+      1th october:
+         * in typed constants is now the conversion int -> real
+           automatically done (FK)
+      3rd october 1997:
+         + started conversion to motorola 68000 - ifdef m68k to find
+           changes (this makes the code look horrible, may later separate
+           in includes?) - look for all ifdef i386 and ifdef m68k to see
+           changes. (CEC)
+         - commented out regnames (was unused) (CEC)
+         + peepholeopt put in i386 define (not yet available for motorola
+            68000) (CEC)
+         + i386 defines around a_att, in a_o and around a_wasm, a_nasm (CEC).
+         + code for in_ord_x (PM)
+      4th october 1997:
+         + checking for double definitions of function/procedure
+           with same parameters in interface (PM)
+         + enums with jumps set the boolean has_jumps and
+           disable the succ and pred use (PM)
+       9th october 1997:
+         * Fixed problem with 80float on the 68000 output, caused a GPF (CEC).
+      13th october 1997:
+         + Added support for Motorola Standard assembler. (CEC)
+       15th october 1997:
+         + added code for static modifier for objects variables and methods
+           controlled by -St switch at command line (PM)
+      17th october 1997:
+        + Added support for Motorola inline assembler (CEC)
+        * Bugfix with .align 4,0x90, this is NOT allowed in TASM/MASM/WASM (CEC).
+        + procedure set_macro and setting of fpc_* macros (FK)
+      19th october 1997:
+        * Bugfix of RTS on 68000 target. PC Counter would become corrupt
+          with paramsize (CEC).
+      23th october 1997:
+        * Small bugfixes concerning SUBI #const,address_reg (CEC).
+      24th october 1997:
+        * array[boolean] works now (FK)
+      25th october 1997:
+        + CDECL and STDCALL (FK)
+        * ASSEMBLER isn't a keyword anymore (FK)
+       3rd november 1997:
+         + added symdif for sets (PM)
+       5th november 1997:
+         * changed all while token<>ATOKEN do consume(token);
+           by a procedure call consume_all_untill(ATOKEN)
+           to test for _EOF (PM)
+         * aktobjectname was not reset to '' at the end of objectcomponenten (PM)
+       14th november 1997:
+         * removed bug for procvar where the type was not allways set correctly (PM)
+         + integer const not in longint range converted to real constant (PM)
+       25th november 1997:
+         * removed bugs due to wrong current_module references in compile procedure (PM)
+
+}
+

compiler/pass_1.pas

@@ -0,0 +1,4704 @@
+{
+    $Id$
+    Copyright (c) 1996-98 by Florian Klaempfl
+
+    This unit implements the first pass of the code generator
+
+    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.
+
+ ****************************************************************************
+}
+
+{$ifdef tp}
+  {$F+}
+{$endif tp}
+unit pass_1;
+
+  interface
+
+    uses tree;
+
+    function do_firstpass(var p : ptree) : boolean;
+
+  implementation
+
+     uses
+        objects,cobjects,verbose,systems,globals,aasm,symtable,
+        types,strings,hcodegen,files
+{$ifdef i386}
+        ,i386
+        ,tgeni386
+{$endif}
+{$ifdef m68k}
+        ,m68k
+        ,tgen68k
+{$endif}
+{$ifdef UseBrowser}
+        ,browser
+{$endif UseBrowser}
+        ;
+
+    { firstcallparan without varspez
+      we don't count the ref }
+    const
+       count_ref : boolean = true;
+
+    procedure error(const t : tmsgconst);
+
+      begin
+         if not(codegenerror) then
+           verbose.Message(t);
+         codegenerror:=true;
+      end;
+
+    procedure firstpass(var p : ptree);forward;
+
+    { marks an lvalue as "unregable" }
+    procedure make_not_regable(p : ptree);
+
+      begin
+         case p^.treetype of
+            typeconvn : make_not_regable(p^.left);
+            loadn : if p^.symtableentry^.typ=varsym then
+                      pvarsym(p^.symtableentry)^.regable:=false;
+         end;
+      end;
+
+
+    { calculates the needed registers for a binary operator }
+    procedure calcregisters(p : ptree;r32,fpu,mmx : word);
+
+      begin
+         p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
+         p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
+
+         { Nur wenn links und rechts ein Unterschied < ben”tige Anzahl ist, }
+         { wird ein zus„tzliches Register ben”tigt, da es dann keinen       }
+         { schwierigeren Ast gibt, welcher erst ausgewertet werden kann     }
+
+         if (abs(p^.left^.registers32-p^.right^.registers32)<r32) then
+           inc(p^.registers32,r32);
+
+         if (abs(p^.left^.registersfpu-p^.right^.registersfpu)<fpu) then
+           inc(p^.registersfpu,fpu);
+
+{$ifdef SUPPORT_MMX}
+         if (abs(p^.left^.registersmmx-p^.right^.registersmmx)<mmx) then
+           inc(p^.registersmmx,mmx);
+{$endif SUPPORT_MMX}
+
+         { error message, if more than 8 floating point }
+         { registers are needed                         }
+         if p^.registersfpu>8 then
+          Message(cg_e_too_complex_expr);
+      end;
+
+    function both_rm(p : ptree) : boolean;
+
+        begin
+           both_rm:=(p^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) and
+             (p^.right^.location.loc in [LOC_MEM,LOC_REFERENCE]);
+        end;
+
+    function isconvertable(def_from,def_to : pdef;
+             var doconv : tconverttype;fromtreetype : ttreetyp) : boolean;
+
+      { from_is_cstring muá true sein, wenn def_from die Definition einer }
+      { Stringkonstanten ist, n”tig wegen der Konvertierung von String-   }
+      { konstante zu nullterminiertem String                              }
+
+      { Hilfsliste: u8bit,s32bit,uvoid,
+                    bool8bit,uchar,s8bit,s16bit,u16bit,u32bit }
+
+      const
+         basedefconverts : array[u8bit..u32bit,u8bit..u32bit] of tconverttype =
+           {u8bit}
+           ((tc_only_rangechecks32bit,tc_u8bit_2_s32bit,tc_not_possible,
+             tc_not_possible,tc_not_possible,tc_only_rangechecks32bit,tc_u8bit_2_s16bit,
+             tc_u8bit_2_u16bit,{tc_not_possible}tc_u8bit_2_u32bit),
+
+           {s32bit}
+            (tc_s32bit_2_u8bit,tc_only_rangechecks32bit,tc_not_possible,
+             tc_not_possible,tc_not_possible,tc_s32bit_2_s8bit,
+             tc_s32bit_2_s16bit,tc_s32bit_2_u16bit,{tc_not_possible}tc_s32bit_2_u32bit),
+
+           {uvoid}
+            (tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible,
+             tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible,
+             tc_not_possible),
+
+           {bool8bit}
+            (tc_not_possible,tc_not_possible,tc_not_possible,
+             tc_only_rangechecks32bit,tc_not_possible,tc_not_possible,tc_not_possible,
+             tc_not_possible,tc_not_possible),
+
+           {uchar}
+            (tc_not_possible,tc_not_possible,tc_not_possible,
+             tc_not_possible,tc_only_rangechecks32bit,tc_not_possible,tc_not_possible,
+             tc_not_possible,tc_not_possible),
+
+           {s8bit}
+            (tc_only_rangechecks32bit,tc_s8bit_2_s32bit,tc_not_possible,
+             tc_not_possible,tc_not_possible,tc_only_rangechecks32bit,tc_s8bit_2_s16bit,
+             tc_s8bit_2_u16bit,{tc_not_possible}tc_s8bit_2_u32bit),
+
+           {s16bit}
+            (tc_s16bit_2_u8bit,tc_s16bit_2_s32bit,tc_not_possible,
+             tc_not_possible,tc_not_possible,tc_s16bit_2_s8bit,tc_only_rangechecks32bit,
+             tc_only_rangechecks32bit,{tc_not_possible}tc_s8bit_2_u32bit),
+
+           {u16bit}
+            (tc_u16bit_2_u8bit,tc_u16bit_2_s32bit,tc_not_possible,
+             tc_not_possible,tc_not_possible,tc_u16bit_2_s8bit,tc_only_rangechecks32bit,
+             tc_only_rangechecks32bit,{tc_not_possible}tc_u16bit_2_u32bit),
+
+           {u32bit}
+            (tc_not_possible,{tc_not_possible}tc_u32bit_2_s32bit,tc_not_possible,
+             tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible,
+             tc_not_possible,tc_only_rangechecks32bit)
+            );
+
+      var
+         b : boolean;
+
+      begin
+         b:=false;
+         if (not assigned(def_from)) or (not assigned(def_to)) then
+          begin
+            isconvertable:=false;
+            exit;
+          end;
+
+         if (def_from^.deftype=orddef) and (def_to^.deftype=orddef) then
+           begin
+              doconv:=basedefconverts[porddef(def_from)^.typ,porddef(def_to)^.typ];
+              if doconv<>tc_not_possible then
+                b:=true;
+           end
+         else if (def_from^.deftype=orddef) and (def_to^.deftype=floatdef) then
+           begin
+              if pfloatdef(def_to)^.typ=f32bit then
+                doconv:=tc_int_2_fix
+              else
+                doconv:=tc_int_2_real;
+              b:=true;
+           end
+         else if (def_from^.deftype=floatdef) and (def_to^.deftype=floatdef) then
+           begin
+              if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then
+                doconv:=tc_equal
+              else
+                begin
+                   if pfloatdef(def_from)^.typ=f32bit then
+                     doconv:=tc_fix_2_real
+                   else if pfloatdef(def_to)^.typ=f32bit then
+                     doconv:=tc_real_2_fix
+                   else
+                     doconv:=tc_real_2_real;
+                   { comp isn't a floating type }
+{$ifdef i386}
+                   if (pfloatdef(def_to)^.typ=s64bit) then
+                     Message(parser_w_convert_real_2_comp);
+{$endif}
+                end;
+              b:=true;
+           end
+         else if (def_from^.deftype=pointerdef) and (def_to^.deftype=arraydef) and
+                 (parraydef(def_to)^.lowrange=0) and
+                 is_equal(ppointerdef(def_from)^.definition,
+                   parraydef(def_to)^.definition) then
+           begin
+              doconv:=tc_pointer_to_array;
+              b:=true;
+           end
+         else if (def_from^.deftype=arraydef) and (def_to^.deftype=pointerdef) and
+                (parraydef(def_from)^.lowrange=0) and
+                is_equal(parraydef(def_from)^.definition,
+                ppointerdef(def_to)^.definition) then
+           begin
+              doconv:=tc_array_to_pointer;
+              b:=true;
+           end
+         { typed files are all equal to the abstract file type
+         name TYPEDFILE in system.pp in is_equal in types.pas
+         the problem is that it sholud be also compatible to FILE
+         but this would leed to a problem for ASSIGN RESET and REWRITE
+         when trying to find the good overloaded function !!
+         so all file function are doubled in system.pp
+         this is not very beautiful !!}
+         else if (def_from^.deftype=filedef) and (def_to^.deftype=filedef) and
+            (
+             (
+              (pfiledef(def_from)^.filetype = ft_typed) and
+              (pfiledef(def_to)^.filetype = ft_typed) and
+              (
+               (pfiledef(def_from)^.typed_as = pdef(voiddef)) or
+               (pfiledef(def_to)^.typed_as = pdef(voiddef))
+              )
+             ) or
+             (
+              (
+               (pfiledef(def_from)^.filetype = ft_untyped) and
+               (pfiledef(def_to)^.filetype = ft_typed)
+              ) or
+              (
+               (pfiledef(def_from)^.filetype = ft_typed) and
+               (pfiledef(def_to)^.filetype = ft_untyped)
+              )
+             )
+            ) then
+           begin
+              doconv:=tc_equal;
+              b:=true;
+           end
+         { object pascal objects }
+         else if (def_from^.deftype=objectdef) and (def_to^.deftype=objectdef) and
+           pobjectdef(def_from)^.isclass and pobjectdef(def_to)^.isclass then
+           begin
+              doconv:=tc_equal;
+              b:=pobjectdef(def_from)^.isrelated(
+                pobjectdef(def_to));
+           end
+         { class reference types }
+         else if (def_from^.deftype=classrefdef) and (def_from^.deftype=classrefdef) then
+           begin
+              doconv:=tc_equal;
+              b:=pobjectdef(pclassrefdef(def_from)^.definition)^.isrelated(
+                pobjectdef(pclassrefdef(def_to)^.definition));
+           end
+
+         else if (def_from^.deftype=pointerdef) and (def_to^.deftype=pointerdef) then
+           begin
+            { child class pointer can be assigned to anchestor pointers }
+            if (
+                (ppointerdef(def_from)^.definition^.deftype=objectdef) and
+                (ppointerdef(def_to)^.definition^.deftype=objectdef) and
+                pobjectdef(ppointerdef(def_from)^.definition)^.isrelated(
+                pobjectdef(ppointerdef(def_to)^.definition))
+               ) or
+               { all pointers can be assigned to void-pointer }
+               is_equal(ppointerdef(def_to)^.definition,voiddef) or
+               { in my opnion, is this not clean pascal }
+               { well, but it's handy to use, it isn't ? (FK) }
+               is_equal(ppointerdef(def_from)^.definition,voiddef) then
+               begin
+                  doconv:=tc_equal;
+                  b:=true;
+               end
+            end
+         else
+           if (def_from^.deftype=stringdef) and (def_to^.deftype=stringdef) then
+             begin
+                doconv:=tc_string_to_string;
+                b:=true;
+             end
+         else
+           { char to string}
+           if is_equal(def_from,cchardef) and
+             (def_to^.deftype=stringdef) then
+             begin
+                doconv:=tc_char_to_string;
+                b:=true;
+             end
+         else
+           { string constant to zero terminated string constant }
+           if (fromtreetype=stringconstn) and
+             (
+              (def_to^.deftype=pointerdef) and
+              is_equal(Ppointerdef(def_to)^.definition,cchardef)
+             ) then
+             begin
+                doconv:=tc_cstring_charpointer;
+                b:=true;
+             end
+         else
+           { array of char to string                                }
+           { the length check is done by the firstpass of this node }
+           if (def_from^.deftype=stringdef) and
+             (
+              (def_to^.deftype=arraydef) and
+              is_equal(parraydef(def_to)^.definition,cchardef)
+             ) then
+             begin
+                doconv:=tc_string_chararray;
+                b:=true;
+             end
+         else
+           { string to array of char }
+           { the length check is done by the firstpass of this node }
+           if (
+               (def_from^.deftype=arraydef) and
+               is_equal(parraydef(def_from)^.definition,cchardef)
+              ) and
+              (def_to^.deftype=stringdef) then
+             begin
+                doconv:=tc_chararray_2_string;
+                b:=true;
+             end
+         else
+           if (fromtreetype=ordconstn) and is_equal(def_from,cchardef) then
+             begin
+                if (def_to^.deftype=pointerdef) and
+                  is_equal(ppointerdef(def_to)^.definition,cchardef) then
+                  begin
+                     doconv:=tc_cchar_charpointer;
+                     b:=true;
+                  end;
+             end
+         else
+           if (def_to^.deftype=procvardef) and (def_from^.deftype=procdef) then
+             begin
+                def_from^.deftype:=procvardef;
+                doconv:=tc_proc2procvar;
+                b:=is_equal(def_from,def_to);
+                def_from^.deftype:=procdef;
+             end
+         else
+           { nil is compatible with class instances }
+           if (fromtreetype=niln) and (def_to^.deftype=objectdef)
+             and (pobjectdef(def_to)^.isclass) then
+             begin
+                doconv:=tc_equal;
+                b:=true;
+             end
+         else
+           { nil is compatible with class references }
+           if (fromtreetype=niln) and (def_to^.deftype=classrefdef) then
+             begin
+                doconv:=tc_equal;
+                b:=true;
+             end
+         { procedure variable can be assigned to an void pointer }
+         { Not anymore. Use the @ operator now.}
+         else
+           if not (cs_tp_compatible in aktswitches) then
+             begin
+                if (def_from^.deftype=procvardef) and
+                  (def_to^.deftype=pointerdef) and
+                  (ppointerdef(def_to)^.definition^.deftype=orddef) and
+                  (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
+                  begin
+                     doconv:=tc_equal;
+                     b:=true;
+                  end;
+             end;
+         isconvertable:=b;
+      end;
+
+    procedure firsterror(var p : ptree);
+
+      begin
+         p^.error:=true;
+         codegenerror:=true;
+         p^.resulttype:=generrordef;
+      end;
+
+    procedure firstload(var p : ptree);
+
+      begin
+         p^.location.loc:=LOC_REFERENCE;
+         p^.registers32:=0;
+         p^.registersfpu:=0;
+
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         clear_reference(p^.location.reference);
+{$ifdef TEST_FUNCRET}
+         if p^.symtableentry^.typ=funcretsym then
+           begin
+              putnode(p);
+              p:=genzeronode(funcretn);
+              p^.funcretprocinfo:=pprocinfo(pfuncretsym(p^.symtableentry)^.funcretprocinfo);
+              p^.retdef:=pfuncretsym(p^.symtableentry)^.retdef;
+              firstpass(p);
+              exit;
+           end;
+{$endif TEST_FUNCRET}
+         if p^.symtableentry^.typ=absolutesym then
+           begin
+              p^.resulttype:=pabsolutesym(p^.symtableentry)^.definition;
+              if pabsolutesym(p^.symtableentry)^.abstyp=tovar then
+                p^.symtableentry:=pabsolutesym(p^.symtableentry)^.ref;
+              p^.symtable:=p^.symtableentry^.owner;
+              p^.is_absolute:=true;
+                   end;
+         case p^.symtableentry^.typ of
+            absolutesym :;
+            varsym :
+                begin
+                   if not(p^.is_absolute) and (p^.resulttype=nil) then
+                     p^.resulttype:=pvarsym(p^.symtableentry)^.definition;
+                   if ((p^.symtable^.symtabletype=parasymtable) or
+                       (p^.symtable^.symtabletype=localsymtable)) and
+                      (lexlevel>p^.symtable^.symtablelevel) then
+                     begin
+                        { sollte sich die Variable in einem anderen Stackframe       }
+                        { befinden, so brauchen wir ein Register zum Dereferenceieren }
+                        if (p^.symtable^.symtablelevel)>0 then
+                          begin
+                             p^.registers32:=1;
+                             { auáerdem kann sie nicht mehr in ein Register
+                               geladen werden }
+                             pvarsym(p^.symtableentry)^.regable:=false;
+                          end;
+                     end;
+                   if (pvarsym(p^.symtableentry)^.varspez=vs_const) then
+                     p^.location.loc:=LOC_MEM;
+                   { we need a register for call by reference parameters }
+                   if (pvarsym(p^.symtableentry)^.varspez=vs_var) or
+                      ((pvarsym(p^.symtableentry)^.varspez=vs_const) and
+                      dont_copy_const_param(pvarsym(p^.symtableentry)^.definition)
+                      ) then
+                     p^.registers32:=1;
+                   if p^.symtable^.symtabletype=withsymtable then
+                     p^.registers32:=1;
+
+                   { a class variable is a pointer !!!
+                     yes, but we have to resolve the reference in an
+                     appropriate tree node (FK)
+
+                   if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and
+                      ((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oois_class)<>0) then
+                     p^.registers32:=1;
+                   }
+
+                   { count variable references }
+
+                   if must_be_valid and p^.is_first then
+                     begin
+                     if pvarsym(p^.symtableentry)^.is_valid=2 then
+                       if (assigned(pvarsym(p^.symtableentry)^.owner) and assigned(aktprocsym)
+                       and (pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst)) then
+                       Message1(sym_n_uninitialized_local_variable,pvarsym(p^.symtableentry)^.name);
+                     end;
+                   if count_ref then
+                     begin
+                        if (p^.is_first) then
+                          begin
+                             if (pvarsym(p^.symtableentry)^.is_valid=2) then
+                               pvarsym(p^.symtableentry)^.is_valid:=1;
+                              p^.is_first:=false;
+                           end;
+                     end;
+                     { this will create problem with local var set by
+                     under_procedures
+                     if (assigned(pvarsym(p^.symtableentry)^.owner) and assigned(aktprocsym)
+                       and ((pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst)
+                       or (pvarsym(p^.symtableentry)^.owner = aktprocsym^.definition^.localst))) then }
+                   if t_times<1 then
+                     inc(pvarsym(p^.symtableentry)^.refs)
+                   else
+                     inc(pvarsym(p^.symtableentry)^.refs,t_times);
+                end;
+            typedconstsym :
+              if not p^.is_absolute then
+                     p^.resulttype:=ptypedconstsym(p^.symtableentry)^.definition;
+            procsym :
+                begin
+                   if assigned(pprocsym(p^.symtableentry)^.definition^.nextoverloaded) then
+                     Message(parser_e_no_overloaded_procvars);
+                   p^.resulttype:=pprocsym(p^.symtableentry)^.definition;
+                end;
+            else internalerror(3);
+         end;
+      end;
+
+    procedure firstadd(var p : ptree);
+
+      var
+         lt,rt : ttreetyp;
+         t : ptree;
+         rv,lv : longint;
+         rvd,lvd : {double}bestreal;
+         rd,ld : pdef;
+         concatstrings : boolean;
+
+         { to evalute const sets }
+         resultset : pconstset;
+         i : longint;
+         b : boolean;
+         s1,s2:^string;
+
+         { this totally forgets to set the pi_do_call flag !! }
+      label
+         no_overload;
+
+      begin
+         { first do the two subtrees }
+         firstpass(p^.left);
+         firstpass(p^.right);
+
+         if codegenerror then
+           exit;
+
+         new(s1);
+         new(s2);
+         { overloaded operator ? }
+         if (p^.treetype=caretn) or
+            (p^.left^.resulttype^.deftype=recorddef) or
+            { <> and = are defined for classes }
+            ((p^.left^.resulttype^.deftype=objectdef) and
+             (not(pobjectdef(p^.left^.resulttype)^.isclass) or
+              not(p^.treetype in [equaln,unequaln])
+             )
+            ) or
+            (p^.right^.resulttype^.deftype=recorddef) or
+            { <> and = are defined for classes }
+            ((p^.right^.resulttype^.deftype=objectdef) and
+             (not(pobjectdef(p^.right^.resulttype)^.isclass) or
+              not(p^.treetype in [equaln,unequaln])
+             )
+            ) then
+           begin
+              {!!!!!!!!! handle paras }
+              case p^.treetype of
+                 { the nil as symtable signs firstcalln that this is
+                   an overloaded operator }
+                 addn:
+                   t:=gencallnode(overloaded_operators[plus],nil);
+                 subn:
+                   t:=gencallnode(overloaded_operators[minus],nil);
+                 muln:
+                   t:=gencallnode(overloaded_operators[star],nil);
+                 caretn:
+                   t:=gencallnode(overloaded_operators[caret],nil);
+                 slashn:
+                   t:=gencallnode(overloaded_operators[slash],nil);
+                 ltn:
+                   t:=gencallnode(overloaded_operators[globals.lt],nil);
+                 gtn:
+                   t:=gencallnode(overloaded_operators[gt],nil);
+                 lten:
+                   t:=gencallnode(overloaded_operators[lte],nil);
+                 gten:
+                   t:=gencallnode(overloaded_operators[gte],nil);
+                 equaln,unequaln :
+                   t:=gencallnode(overloaded_operators[equal],nil);
+                 else goto no_overload;
+              end;
+              { we have to convert p^.left and p^.right into
+               callparanodes }
+              t^.left:=gencallparanode(p^.left,nil);
+              t^.left:=gencallparanode(p^.right,t^.left);
+              if t^.symtableprocentry=nil then
+               Message(parser_e_operator_not_overloaded);
+              if p^.treetype=unequaln then
+               t:=gensinglenode(notn,t);
+              dispose(s1);
+              dispose(s2);
+              firstpass(t);
+              putnode(p);
+              p:=t;
+              exit;
+           end;
+         no_overload:
+         { compact consts }
+         lt:=p^.left^.treetype;
+         rt:=p^.right^.treetype;
+
+         { convert int consts to real consts, if the }
+         { other operand is a real const             }
+         if is_constintnode(p^.left) and
+           (rt=realconstn) then
+           begin
+              t:=genrealconstnode(p^.left^.value);
+              disposetree(p^.left);
+              p^.left:=t;
+              lt:=realconstn;
+           end;
+         if is_constintnode(p^.right) and
+            (lt=realconstn) then
+           begin
+              t:=genrealconstnode(p^.right^.value);
+              disposetree(p^.right);
+              p^.right:=t;
+              rt:=realconstn;
+           end;
+
+         if is_constintnode(p^.left) and
+           is_constintnode(p^.right) then
+           begin
+              lv:=p^.left^.value;
+              rv:=p^.right^.value;
+              case p^.treetype of
+                 addn:
+                   t:=genordinalconstnode(lv+rv,s32bitdef);
+                 subn:
+                   t:=genordinalconstnode(lv-rv,s32bitdef);
+                 muln:
+                   t:=genordinalconstnode(lv*rv,s32bitdef);
+                 xorn:
+                   t:=genordinalconstnode(lv xor rv,s32bitdef);
+                 orn:
+                   t:=genordinalconstnode(lv or rv,s32bitdef);
+                 andn:
+                   t:=genordinalconstnode(lv and rv,s32bitdef);
+                 ltn:
+                   t:=genordinalconstnode(ord(lv<rv),booldef);
+                 lten:
+                   t:=genordinalconstnode(ord(lv<=rv),booldef);
+                 gtn:
+                   t:=genordinalconstnode(ord(lv>rv),booldef);
+                 gten:
+                   t:=genordinalconstnode(ord(lv>=rv),booldef);
+                 equaln:
+                   t:=genordinalconstnode(ord(lv=rv),booldef);
+                 unequaln:
+                   t:=genordinalconstnode(ord(lv<>rv),booldef);
+                 slashn :
+                   begin
+                      { int/int becomes a real }
+                      t:=genrealconstnode(int(lv)/int(rv));
+                      firstpass(t);
+                   end;
+                 else
+                   Message(sym_e_type_mismatch);
+                end;
+              disposetree(p);
+              dispose(s1);
+              dispose(s2);
+              p:=t;
+              exit;
+              end
+         else
+           { real constants }
+           if (lt=realconstn) and (rt=realconstn) then
+           begin
+              lvd:=p^.left^.valued;
+              rvd:=p^.right^.valued;
+              case p^.treetype of
+                 addn:
+                   t:=genrealconstnode(lvd+rvd);
+                 subn:
+                   t:=genrealconstnode(lvd-rvd);
+                 muln:
+                   t:=genrealconstnode(lvd*rvd);
+                 caretn:
+                   t:=genrealconstnode(exp(ln(lvd)*rvd));
+                 slashn:
+                   t:=genrealconstnode(lvd/rvd);
+                 ltn:
+                   t:=genordinalconstnode(ord(lvd<rvd),booldef);
+                 lten:
+                   t:=genordinalconstnode(ord(lvd<=rvd),booldef);
+                 gtn:
+                   t:=genordinalconstnode(ord(lvd>rvd),booldef);
+                 gten:
+                   t:=genordinalconstnode(ord(lvd>=rvd),booldef);
+                 equaln:
+                   t:=genordinalconstnode(ord(lvd=rvd),booldef);
+                 unequaln:
+                   t:=genordinalconstnode(ord(lvd<>rvd),booldef);
+                 else
+                   Message(sym_e_type_mismatch);
+              end;
+              disposetree(p);
+              p:=t;
+              dispose(s1);
+              dispose(s2);
+              firstpass(p);
+              exit;
+           end;
+         concatstrings:=false;
+         if (lt=ordconstn) and (rt=ordconstn) and
+           (p^.left^.resulttype^.deftype=orddef) and
+           (porddef(p^.left^.resulttype)^.typ=uchar) and
+           (p^.right^.resulttype^.deftype=orddef) and
+           (porddef(p^.right^.resulttype)^.typ=uchar) then
+           begin
+              s1^:=char(byte(p^.left^.value));
+              s2^:=char(byte(p^.right^.value));
+              concatstrings:=true;
+           end
+         else if (lt=stringconstn) and (rt=ordconstn) and
+           (p^.right^.resulttype^.deftype=orddef) and
+           (porddef(p^.right^.resulttype)^.typ=uchar) then
+           begin
+              s1^:=Pstring(p^.left^.value)^;
+              s2^:=char(byte(p^.right^.value));
+              concatstrings:=true;
+           end
+         else if (lt=ordconstn) and (rt=stringconstn) and
+           (p^.left^.resulttype^.deftype=orddef) and
+           (porddef(p^.left^.resulttype)^.typ=uchar) then
+           begin
+              s1^:=char(byte(p^.left^.value));
+              s2^:=pstring(p^.right^.value)^;
+              concatstrings:=true;
+           end
+         else if (lt=stringconstn) and (rt=stringconstn) then
+           begin
+              s1^:=pstring(p^.left^.value)^;
+              s2^:=pstring(p^.right^.value)^;
+              concatstrings:=true;
+           end;
+
+         if concatstrings then
+           begin
+              case p^.treetype of
+                 addn : t:=genstringconstnode(s1^+s2^);
+                 ltn : t:=genordinalconstnode(byte(s1^<s2^),booldef);
+                 lten : t:=genordinalconstnode(byte(s1^<=s2^),booldef);
+                 gtn : t:=genordinalconstnode(byte(s1^>s2^),booldef);
+                 gten : t:=genordinalconstnode(byte(s1^>=s2^),booldef);
+                 equaln : t:=genordinalconstnode(byte(s1^=s2^),booldef);
+                 unequaln : t:=genordinalconstnode(byte(s1^<>s2^),booldef);
+              end;
+              dispose(s1);
+              dispose(s2);
+              disposetree(p);
+              p:=t;
+              exit;
+           end;
+         rd:=p^.right^.resulttype;
+         ld:=p^.left^.resulttype;
+         dispose(s1);
+         dispose(s2);
+
+         { we can set this globally but it not allways true }
+         { procinfo.flags:=procinfo.flags or pi_do_call;    }
+
+         { if both are boolean: }
+         if ((ld^.deftype=orddef) and
+            (porddef(ld)^.typ=bool8bit)) and
+            ((rd^.deftype=orddef) and
+            (porddef(rd)^.typ=bool8bit)) then
+           begin
+              if (p^.treetype=andn) or (p^.treetype=orn) then
+                begin
+                   calcregisters(p,0,0,0);
+                   p^.location.loc:=LOC_JUMP;
+                end
+              else if p^.treetype in [unequaln,equaln,xorn] then
+                begin
+                   { I'am not very content with this solution, but it's
+                     a working hack    (FK)                             }
+                   p^.left:=gentypeconvnode(p^.left,u8bitdef);
+                   p^.right:=gentypeconvnode(p^.right,u8bitdef);
+                   p^.left^.convtyp:=tc_bool_2_u8bit;
+                   p^.left^.explizit:=true;
+                   firstpass(p^.left);
+                   p^.left^.resulttype:=booldef;
+                   p^.right^.convtyp:=tc_bool_2_u8bit;
+                   p^.right^.explizit:=true;
+                   firstpass(p^.right);
+                   p^.right^.resulttype:=booldef;
+                   calcregisters(p,1,0,0);
+                   { is done commonly for all data types
+                   p^.location.loc:=LOC_FLAGS;
+                   p^.resulttype:=booldef;
+                   }
+                end
+              else Message(sym_e_type_mismatch);
+           end
+         { wenn beides vom Char dann keine Konvertiereung einf�gen }
+         { h”chstens es handelt sich um einen +-Operator           }
+         else if ((rd^.deftype=orddef) and (porddef(rd)^.typ=uchar)) and
+            ((ld^.deftype=orddef) and (porddef(ld)^.typ=uchar)) then
+            begin
+               if p^.treetype=addn then
+                 begin
+                    p^.left:=gentypeconvnode(p^.left,cstringdef);
+                    firstpass(p^.left);
+                    p^.right:=gentypeconvnode(p^.right,cstringdef);
+                    firstpass(p^.right);
+                    { here we call STRCOPY }
+                    procinfo.flags:=procinfo.flags or pi_do_call;
+                    calcregisters(p,0,0,0);
+                    p^.location.loc:=LOC_MEM;
+                 end
+               else
+                calcregisters(p,1,0,0);
+            end
+         { if string and character, then conver the character to a string }
+         else if ((rd^.deftype=stringdef) and
+                 ((ld^.deftype=orddef) and (porddef(ld)^.typ=uchar))) or
+                 ((ld^.deftype=stringdef) and
+                 ((rd^.deftype=orddef) and (porddef(rd)^.typ=uchar))) then
+           begin
+              if ((ld^.deftype=orddef) and (porddef(ld)^.typ=uchar)) then
+                p^.left:=gentypeconvnode(p^.left,cstringdef)
+              else
+                p^.right:=gentypeconvnode(p^.right,cstringdef);
+              firstpass(p^.left);
+              firstpass(p^.right);
+              { here we call STRCONCAT or STRCMP }
+              procinfo.flags:=procinfo.flags or pi_do_call;
+              calcregisters(p,0,0,0);
+              p^.location.loc:=LOC_MEM;
+           end
+         else
+           if ((rd^.deftype=setdef) and (ld^.deftype=setdef)) then
+             begin
+                case p^.treetype of
+                   subn,symdifn,addn,muln,equaln,unequaln : ;
+                   else Message(sym_e_type_mismatch);
+                end;
+                if not(is_equal(rd,ld)) then
+                 Message(sym_e_set_element_are_not_comp);
+                firstpass(p^.left);
+                firstpass(p^.right);
+                { do constant evalution }
+                { set constructor ? }
+                if (p^.right^.treetype=setconstrn) and
+                  (p^.left^.treetype=setconstrn) and
+                  { and no variables ? }
+                  (p^.right^.left=nil) and
+                  (p^.left^.left=nil) then
+                  begin
+                     new(resultset);
+                     case p^.treetype of
+                        addn : begin
+                                  for i:=0 to 31 do
+                                    resultset^[i]:=
+                                      p^.right^.constset^[i] or p^.left^.constset^[i];
+                                  t:=gensetconstruktnode(resultset,psetdef(ld));
+                               end;
+                        muln : begin
+                                  for i:=0 to 31 do
+                                    resultset^[i]:=
+                                      p^.right^.constset^[i] and p^.left^.constset^[i];
+                                  t:=gensetconstruktnode(resultset,psetdef(ld));
+                               end;
+                        subn : begin
+                                  for i:=0 to 31 do
+                                    resultset^[i]:=
+                                      p^.left^.constset^[i] and not(p^.right^.constset^[i]);
+                                  t:=gensetconstruktnode(resultset,psetdef(ld));
+                               end;
+                        symdifn : begin
+                                  for i:=0 to 31 do
+                                    resultset^[i]:=
+                                      p^.left^.constset^[i] xor p^.right^.constset^[i];
+                                  t:=gensetconstruktnode(resultset,psetdef(ld));
+                               end;
+                        unequaln : begin
+                                      b:=true;
+                                      for i:=0 to 31 do
+                                        if p^.right^.constset^[i]=p^.left^.constset^[i] then
+                                          begin
+                                             b:=false;
+                                             break;
+                                          end;
+                                      t:=genordinalconstnode(ord(b),booldef);
+                                   end;
+                        equaln : begin
+                                    b:=true;
+                                    for i:=0 to 31 do
+                                      if p^.right^.constset^[i]<>p^.left^.constset^[i] then
+                                        begin
+                                           b:=false;
+                                           break;
+                                        end;
+                                     t:=genordinalconstnode(ord(b),booldef);
+                                  end;
+                     end;
+                     dispose(resultset);
+                     disposetree(p);
+                     p:=t;
+                     firstpass(p);
+                     exit;
+                  end
+                else if psetdef(rd)^.settype=smallset then
+                  begin
+                     calcregisters(p,1,0,0);
+                     p^.location.loc:=LOC_REGISTER;
+                  end
+                else
+                  begin
+                     calcregisters(p,0,0,0);
+                     { here we call SET... }
+                     procinfo.flags:=procinfo.flags or pi_do_call;
+                     p^.location.loc:=LOC_MEM;
+                  end;
+             end
+         else
+           if ((rd^.deftype=stringdef) and (ld^.deftype=stringdef)) then
+             { here we call STR... }
+             procinfo.flags:=procinfo.flags or pi_do_call
+         { if there is a real float, convert both to float 80 bit }
+         else
+         if ((rd^.deftype=floatdef) and (pfloatdef(rd)^.typ<>f32bit)) or
+           ((ld^.deftype=floatdef) and (pfloatdef(ld)^.typ<>f32bit)) then
+           begin
+              p^.right:=gentypeconvnode(p^.right,c64floatdef);
+              p^.left:=gentypeconvnode(p^.left,c64floatdef);
+              firstpass(p^.left);
+              firstpass(p^.right);
+              calcregisters(p,1,1,0);
+              p^.location.loc:=LOC_FPU;
+           end
+         else
+          { if there is one fix comma number, convert both to 32 bit fixcomma }
+           if ((rd^.deftype=floatdef) and (pfloatdef(rd)^.typ=f32bit)) or
+             ((ld^.deftype=floatdef) and (pfloatdef(ld)^.typ=f32bit)) then
+            begin
+               if not(porddef(rd)^.typ in [u8bit,s8bit,u16bit,
+                 s16bit,s32bit]) or (p^.treetype<>muln) then
+                   p^.right:=gentypeconvnode(p^.right,s32fixeddef);
+
+               if not(porddef(rd)^.typ in [u8bit,s8bit,u16bit,
+                 s16bit,s32bit]) or (p^.treetype<>muln) then
+               p^.left:=gentypeconvnode(p^.left,s32fixeddef);
+
+               firstpass(p^.left);
+               firstpass(p^.right);
+               calcregisters(p,1,0,0);
+               p^.location.loc:=LOC_REGISTER;
+            end
+         { pointer comperation and subtraction }
+         else if (rd^.deftype=pointerdef) and (ld^.deftype=pointerdef) then
+           begin
+              p^.location.loc:=LOC_REGISTER;
+              p^.right:=gentypeconvnode(p^.right,ld);
+              firstpass(p^.right);
+              calcregisters(p,1,0,0);
+              case p^.treetype of
+                 equaln,unequaln : ;
+                 ltn,lten,gtn,gten:
+                   begin
+                      if not(cs_extsyntax in aktswitches) then
+                        Message(sym_e_type_mismatch);
+                   end;
+                 subn:
+                   begin
+                      if not(cs_extsyntax in aktswitches) then
+                        Message(sym_e_type_mismatch);
+                      p^.resulttype:=s32bitdef;
+                      exit;
+                   end;
+                 else Message(sym_e_type_mismatch);
+              end;
+           end
+         else if (rd^.deftype=objectdef) and (ld^.deftype=objectdef) and
+           pobjectdef(rd)^.isclass and pobjectdef(ld)^.isclass then
+           begin
+              p^.location.loc:=LOC_REGISTER;
+              if pobjectdef(rd)^.isrelated(pobjectdef(ld)) then
+                p^.right:=gentypeconvnode(p^.right,ld)
+              else
+                p^.left:=gentypeconvnode(p^.left,rd);
+              firstpass(p^.right);
+              firstpass(p^.left);
+              calcregisters(p,1,0,0);
+              case p^.treetype of
+                 equaln,unequaln : ;
+                 else Message(sym_e_type_mismatch);
+              end;
+           end
+         else if (rd^.deftype=classrefdef) and (ld^.deftype=classrefdef) then
+           begin
+              p^.location.loc:=LOC_REGISTER;
+              if pobjectdef(pclassrefdef(rd)^.definition)^.isrelated(pobjectdef(
+                pclassrefdef(ld)^.definition)) then
+                p^.right:=gentypeconvnode(p^.right,ld)
+              else
+                p^.left:=gentypeconvnode(p^.left,rd);
+              firstpass(p^.right);
+              firstpass(p^.left);
+              calcregisters(p,1,0,0);
+              case p^.treetype of
+                 equaln,unequaln : ;
+                 else Message(sym_e_type_mismatch);
+              end;
+           end
+
+         { allows comperasion with nil pointer }
+         else if (rd^.deftype=objectdef) and
+           pobjectdef(rd)^.isclass then
+           begin
+              p^.location.loc:=LOC_REGISTER;
+              p^.left:=gentypeconvnode(p^.left,rd);
+              firstpass(p^.left);
+              calcregisters(p,1,0,0);
+              case p^.treetype of
+                 equaln,unequaln : ;
+                 else Message(sym_e_type_mismatch);
+              end;
+           end
+         else if (ld^.deftype=objectdef) and
+           pobjectdef(ld)^.isclass then
+           begin
+              p^.location.loc:=LOC_REGISTER;
+              p^.right:=gentypeconvnode(p^.right,ld);
+              firstpass(p^.right);
+              calcregisters(p,1,0,0);
+              case p^.treetype of
+                 equaln,unequaln : ;
+                 else Message(sym_e_type_mismatch);
+              end;
+           end
+         else if (rd^.deftype=classrefdef) then
+           begin
+              p^.left:=gentypeconvnode(p^.left,rd);
+              firstpass(p^.left);
+              calcregisters(p,1,0,0);
+              case p^.treetype of
+                 equaln,unequaln : ;
+                 else Message(sym_e_type_mismatch);
+              end;
+           end
+         else if (ld^.deftype=classrefdef) then
+           begin
+              p^.right:=gentypeconvnode(p^.right,ld);
+              firstpass(p^.right);
+              calcregisters(p,1,0,0);
+              case p^.treetype of
+                 equaln,unequaln : ;
+                 else Message(sym_e_type_mismatch);
+              end;
+           end
+
+         else if (rd^.deftype=pointerdef) then
+           begin
+              p^.location.loc:=LOC_REGISTER;
+              p^.left:=gentypeconvnode(p^.left,s32bitdef);
+              firstpass(p^.left);
+              calcregisters(p,1,0,0);
+              if p^.treetype=addn then
+                begin
+                   if not(cs_extsyntax in aktswitches) then
+                     Message(sym_e_type_mismatch);
+                end
+              else Message(sym_e_type_mismatch);
+           end
+         else if (ld^.deftype=pointerdef) then
+           begin
+              p^.location.loc:=LOC_REGISTER;
+              p^.right:=gentypeconvnode(p^.right,s32bitdef);
+              firstpass(p^.right);
+              calcregisters(p,1,0,0);
+              case p^.treetype of
+                 addn,subn : if not(cs_extsyntax in aktswitches) then
+                               Message(sym_e_type_mismatch);
+                 else Message(sym_e_type_mismatch);
+              end;
+           end
+         else if (rd^.deftype=procvardef) and (ld^.deftype=procvardef) and
+           is_equal(rd,ld) then
+           begin
+              calcregisters(p,1,0,0);
+              p^.location.loc:=LOC_REGISTER;
+              case p^.treetype of
+                 equaln,unequaln : ;
+                 else Message(sym_e_type_mismatch);
+              end;
+           end
+         else if (ld^.deftype=enumdef) and (rd^.deftype=enumdef)
+            and (is_equal(ld,rd)) then
+           begin
+              calcregisters(p,1,0,0);
+              case p^.treetype of
+                 equaln,unequaln,
+                 ltn,lten,gtn,gten : ;
+                 else Message(sym_e_type_mismatch);
+              end;
+           end
+{$ifdef SUPPORT_MMX}
+         else if (cs_mmx in aktswitches) and is_mmx_able_array(ld)
+           and is_mmx_able_array(rd) and is_equal(ld,rd) then
+           begin
+              firstpass(p^.right);
+              firstpass(p^.left);
+              case p^.treetype of
+                addn,subn,xorn,orn,andn:
+                  ;
+                { mul is a little bit restricted }
+                muln:
+                  if not(mmx_type(p^.left^.resulttype) in
+                    [mmxu16bit,mmxs16bit,mmxfixed16]) then
+                    Message(sym_e_type_mismatch);
+                else
+                  Message(sym_e_type_mismatch);
+              end;
+              p^.location.loc:=LOC_MMXREGISTER;
+              calcregisters(p,0,0,1);
+       end
+{$endif SUPPORT_MMX}
+         { the general solution is to convert to 32 bit int }
+         else
+           begin
+              { but an int/int gives real/real! }
+              if p^.treetype=slashn then
+                begin
+                   Message(parser_w_use_int_div_int_op);
+                   p^.right:=gentypeconvnode(p^.right,c64floatdef);
+                   p^.left:=gentypeconvnode(p^.left,c64floatdef);
+                   firstpass(p^.left);
+                   firstpass(p^.right);
+                   { maybe we need an integer register to save }
+                   { a reference                               }
+                   if ((p^.left^.location.loc<>LOC_FPU) or
+                       (p^.right^.location.loc<>LOC_FPU)) and
+                       (p^.left^.registers32=p^.right^.registers32) then
+                     calcregisters(p,1,1,0)
+                   else
+                     calcregisters(p,0,1,0);
+                   p^.location.loc:=LOC_FPU;
+                end
+              else
+                begin
+                   p^.right:=gentypeconvnode(p^.right,s32bitdef);
+                   p^.left:=gentypeconvnode(p^.left,s32bitdef);
+                   firstpass(p^.left);
+                   firstpass(p^.right);
+                   calcregisters(p,1,0,0);
+                   p^.location.loc:=LOC_REGISTER;
+                end;
+           end;
+
+         if codegenerror then
+           exit;
+
+         { determines result type for comparions }
+         case p^.treetype of
+            ltn,lten,gtn,gten,equaln,unequaln:
+              begin
+                 p^.resulttype:=booldef;
+                 p^.location.loc:=LOC_FLAGS;
+              end;
+            addn:
+              begin
+                 { the result of a string addition is a string of length 255 }
+                 if (p^.left^.resulttype^.deftype=stringdef) or
+                    (p^.right^.resulttype^.deftype=stringdef) then
+                   p^.resulttype:=cstringdef
+                 else
+                   p^.resulttype:=p^.left^.resulttype;
+              end;
+            else p^.resulttype:=p^.left^.resulttype;
+         end;
+      end;
+
+    procedure firstmoddiv(var p : ptree);
+
+      var
+         t : ptree;
+         {power : longint; }
+
+      begin
+         firstpass(p^.left);
+         firstpass(p^.right);
+
+         if codegenerror then
+           exit;
+
+         if is_constintnode(p^.left) and is_constintnode(p^.right) then
+           begin
+              case p^.treetype of
+                 modn : t:=genordinalconstnode(p^.left^.value mod p^.right^.value,s32bitdef);
+                 divn : t:=genordinalconstnode(p^.left^.value div p^.right^.value,s32bitdef);
+              end;
+              disposetree(p);
+              p:=t;
+              exit;
+           end;
+         { !!!!!! u32bit }
+         p^.right:=gentypeconvnode(p^.right,s32bitdef);
+         p^.left:=gentypeconvnode(p^.left,s32bitdef);
+         firstpass(p^.left);
+         firstpass(p^.right);
+
+         if codegenerror then
+           exit;
+
+         p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
+         p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
+         if p^.registers32<2 then p^.registers32:=2;
+
+         p^.resulttype:=s32bitdef;
+         p^.location.loc:=LOC_REGISTER;
+      end;
+
+    procedure firstshlshr(var p : ptree);
+
+      var
+         t : ptree;
+
+      begin
+         firstpass(p^.left);
+         firstpass(p^.right);
+
+         if codegenerror then
+           exit;
+
+         if is_constintnode(p^.left) and is_constintnode(p^.right) then
+           begin
+              case p^.treetype of
+                 shrn : t:=genordinalconstnode(p^.left^.value shr p^.right^.value,s32bitdef);
+                 shln : t:=genordinalconstnode(p^.left^.value shl p^.right^.value,s32bitdef);
+              end;
+              disposetree(p);
+              p:=t;
+              exit;
+           end;
+         p^.right:=gentypeconvnode(p^.right,s32bitdef);
+         p^.left:=gentypeconvnode(p^.left,s32bitdef);
+         firstpass(p^.left);
+         firstpass(p^.right);
+
+         if codegenerror then
+           exit;
+
+         calcregisters(p,2,0,0);
+         {
+         p^.registers32:=p^.left^.registers32;
+
+         if p^.registers32<p^.right^.registers32 then
+           p^.registers32:=p^.right^.registers32;
+         if p^.registers32<1 then p^.registers32:=1;
+         }
+         p^.resulttype:=s32bitdef;
+         p^.location.loc:=LOC_REGISTER;
+      end;
+
+    procedure firstrealconst(var p : ptree);
+
+      begin
+         p^.location.loc:=LOC_MEM;
+      end;
+
+    procedure firstfixconst(var p : ptree);
+
+      begin
+         p^.location.loc:=LOC_MEM;
+      end;
+
+    procedure firstordconst(var p : ptree);
+
+      begin
+         p^.location.loc:=LOC_MEM;
+      end;
+
+    procedure firstniln(var p : ptree);
+
+      begin
+         p^.resulttype:=voidpointerdef;
+         p^.location.loc:=LOC_MEM;
+      end;
+
+    procedure firststringconst(var p : ptree);
+
+      begin
+{$ifdef GDB}
+         {why this !!! lost of dummy type definitions
+         one per const string !!!
+         p^.resulttype:=new(pstringdef,init(length(p^.values^)));}
+         p^.resulttype:=cstringdef;
+{$Else GDB}
+         p^.resulttype:=new(pstringdef,init(length(p^.values^)));
+{$endif * GDB *}
+         p^.location.loc:=LOC_MEM;
+      end;
+
+    procedure firstumminus(var p : ptree);
+
+      var
+         t : ptree;
+         minusdef : pprocdef;
+
+      begin
+         firstpass(p^.left);
+         p^.registers32:=p^.left^.registers32;
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=p^.left^.resulttype;
+         if codegenerror then
+           exit;
+         if is_constintnode(p^.left) then
+           begin
+              t:=genordinalconstnode(-p^.left^.value,s32bitdef);
+              disposetree(p);
+              firstpass(t);
+              p:=t;
+              exit;
+           end;
+           { nasm can not cope with negativ reals !! }
+         if is_constrealnode(p^.left)
+{$ifdef i386}
+         and (current_module^.output_format<>of_nasm)
+{$endif}
+           then
+           begin
+              t:=genrealconstnode(-p^.left^.valued);
+              disposetree(p);
+              firstpass(t);
+              p:=t;
+              exit;
+           end;
+         if (p^.left^.resulttype^.deftype=floatdef) then
+           begin
+              if pfloatdef(p^.left^.resulttype)^.typ=f32bit then
+                begin
+                   if (p^.left^.location.loc<>LOC_REGISTER) and
+                     (p^.registers32<1) then
+                     p^.registers32:=1;
+                   p^.location.loc:=LOC_REGISTER;
+                end
+              else
+                p^.location.loc:=LOC_FPU;
+           end
+{$ifdef SUPPORT_MMX}
+         else if (cs_mmx in aktswitches) and
+           is_mmx_able_array(p^.left^.resulttype) then
+             begin
+               if (p^.left^.location.loc<>LOC_MMXREGISTER) and
+                 (p^.registersmmx<1) then
+                 p^.registersmmx:=1;
+               { if saturation is on, p^.left^.resulttype isn't
+                 "mmx able" (FK)
+               if (cs_mmx_saturation in aktswitches^) and
+                 (porddef(parraydef(p^.resulttype)^.definition)^.typ in
+                 [s32bit,u32bit]) then
+                 Message(sym_e_type_mismatch);
+               }
+             end
+{$endif SUPPORT_MMX}
+         else if (p^.left^.resulttype^.deftype=orddef) then
+           begin
+              p^.left:=gentypeconvnode(p^.left,s32bitdef);
+              firstpass(p^.left);
+              p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+              p^.registers32:=p^.left^.registers32;
+              if codegenerror then
+                exit;
+              if (p^.left^.location.loc<>LOC_REGISTER) and
+                (p^.registers32<1) then
+              p^.registers32:=1;
+              p^.location.loc:=LOC_REGISTER;
+              p^.resulttype:=p^.left^.resulttype;
+           end
+         else
+           begin
+              if assigned(overloaded_operators[minus]) then
+                minusdef:=overloaded_operators[minus]^.definition
+              else
+                minusdef:=nil;
+              while assigned(minusdef) do
+                begin
+                   if (minusdef^.para1^.data=p^.left^.resulttype) and
+                     (minusdef^.para1^.next=nil) then
+                     begin
+                        t:=gencallnode(overloaded_operators[minus],nil);
+                        t^.left:=gencallparanode(p^.left,nil);
+                        putnode(p);
+                        p:=t;
+                        firstpass(p);
+                        exit;
+                     end;
+                   minusdef:=minusdef^.nextoverloaded;
+                end;
+              Message(sym_e_type_mismatch);
+           end;
+      end;
+
+    procedure firstaddr(var p : ptree);
+
+      var
+         hp  : ptree;
+         hp2 : pdefcoll;
+         store_valid : boolean;
+
+      begin
+         make_not_regable(p^.left);
+         if not(assigned(p^.resulttype)) then
+           begin
+              if p^.left^.treetype=calln then
+                begin
+                   hp:=genloadnode(pvarsym(p^.left^.symtableprocentry),p^.left^.symtableproc);
+                   { result is a procedure variable }
+                   { No, to be TP compatible, you must return a pointer to
+                     the procedure that is stored in the procvar.}
+                   if not(cs_tp_compatible in aktswitches) then
+                     begin
+                        p^.resulttype:=new(pprocvardef,init);
+
+                        pprocvardef(p^.resulttype)^.options:=
+                          p^.left^.symtableprocentry^.definition^.options;
+
+                        pprocvardef(p^.resulttype)^.retdef:=
+                          p^.left^.symtableprocentry^.definition^.retdef;
+
+                        hp2:=p^.left^.symtableprocentry^.definition^.para1;
+                        while assigned(hp2) do
+                          begin
+                             pprocvardef(p^.resulttype)^.concatdef(hp2^.data,hp2^.paratyp);
+                             hp2:=hp2^.next;
+                          end;
+                     end
+                   else
+                     p^.resulttype:=voidpointerdef;
+
+                   disposetree(p^.left);
+                   p^.left:=hp;
+                end
+              else
+                begin
+                  if not(cs_typed_addresses in aktswitches) then
+                    p^.resulttype:=voidpointerdef
+                  else p^.resulttype:=new(ppointerdef,init(p^.left^.resulttype));
+                end;
+           end;
+         store_valid:=must_be_valid;
+         must_be_valid:=false;
+         firstpass(p^.left);
+         must_be_valid:=store_valid;
+         if codegenerror then
+           exit;
+
+         { we should allow loc_mem for @string }
+         if (p^.left^.location.loc<>LOC_REFERENCE) and
+            (p^.left^.location.loc<>LOC_MEM) then
+           Message(cg_e_illegal_expression);
+
+         p^.registers32:=p^.left^.registers32;
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+         if p^.registers32<1 then
+           p^.registers32:=1;
+         p^.location.loc:=LOC_REGISTER;
+      end;
+
+    procedure firstdoubleaddr(var p : ptree);
+
+      var
+         hp  : ptree;
+         hp2 : pdefcoll;
+
+      begin
+         make_not_regable(p^.left);
+         firstpass(p^.left);
+         if p^.resulttype=nil then
+                p^.resulttype:=voidpointerdef;
+         if (p^.left^.resulttype^.deftype)<>procvardef then
+                Message(cg_e_illegal_expression);
+
+         if codegenerror then
+           exit;
+
+         if (p^.left^.location.loc<>LOC_REFERENCE) then
+           Message(cg_e_illegal_expression);
+
+         p^.registers32:=p^.left^.registers32;
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+         if p^.registers32<1 then
+           p^.registers32:=1;
+         p^.location.loc:=LOC_REGISTER;
+      end;
+
+    procedure firstnot(var p : ptree);
+
+      var
+         t : ptree;
+
+      begin
+         firstpass(p^.left);
+
+         if codegenerror then
+           exit;
+
+         if (p^.left^.treetype=ordconstn) then
+           begin
+              t:=genordinalconstnode(not(p^.left^.value),p^.left^.resulttype);
+              disposetree(p);
+              p:=t;
+              exit;
+           end;
+         p^.resulttype:=p^.left^.resulttype;
+         p^.location.loc:=p^.left^.location.loc;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+         if is_equal(p^.resulttype,booldef) then
+           begin
+              p^.registers32:=p^.left^.registers32;
+              if ((p^.location.loc=LOC_REFERENCE) or
+                (p^.location.loc=LOC_CREGISTER)) and
+                (p^.registers32<1) then
+                p^.registers32:=1;
+           end
+         else
+{$ifdef SUPPORT_MMX}
+           if (cs_mmx in aktswitches) and
+             is_mmx_able_array(p^.left^.resulttype) then
+             begin
+               if (p^.left^.location.loc<>LOC_MMXREGISTER) and
+                 (p^.registersmmx<1) then
+                 p^.registersmmx:=1;
+             end
+         else
+{$endif SUPPORT_MMX}
+           begin
+              p^.left:=gentypeconvnode(p^.left,s32bitdef);
+              firstpass(p^.left);
+
+              if codegenerror then
+                exit;
+
+              p^.resulttype:=p^.left^.resulttype;
+              p^.registers32:=p^.left^.registers32;
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+
+              if (p^.left^.location.loc<>LOC_REGISTER) and
+                (p^.registers32<1) then
+                p^.registers32:=1;
+              p^.location.loc:=LOC_REGISTER;
+           end;
+         p^.registersfpu:=p^.left^.registersfpu;
+      end;
+
+    procedure firstnothing(var p : ptree);
+
+      begin
+      end;
+
+    procedure firstassignment(var p : ptree);
+
+      var
+         store_valid : boolean;
+         hp : ptree;
+
+      begin
+         store_valid:=must_be_valid;
+         must_be_valid:=false;
+         firstpass(p^.left);
+         { assignements to open arrays aren't allowed }
+         if is_open_array(p^.left^.resulttype) then
+           Message(sym_e_type_mismatch);
+{$ifdef dummyi386}
+         if ((p^.right^.treetype=addn) or (p^.right^.treetype=subn)) and
+            equal_trees(p^.left,p^.right^.left) and
+            (ret_in_acc(p^.left^.resulttype)) and
+            (not cs_rangechecking in aktswitches^) then
+           begin
+              disposetree(p^.right^.left);
+              hp:=p^.right;
+              p^.right:=p^.right^.right;
+              if hp^.treetype=addn then
+                p^.assigntyp:=at_plus
+              else
+                p^.assigntyp:=at_minus;
+              putnode(hp);
+           end;
+         if p^.assigntyp<>at_normal then
+           begin
+              { for fpu type there is no faster way }
+              if is_fpu(p^.left^.resulttype) then
+                case p^.assigntyp of
+                  at_plus  : p^.right:=gennode(addn,getcopy(p^.left),p^.right);
+                  at_minus : p^.right:=gennode(subn,getcopy(p^.left),p^.right);
+                  at_star  : p^.right:=gennode(muln,getcopy(p^.left),p^.right);
+                  at_slash : p^.right:=gennode(slashn,getcopy(p^.left),p^.right);
+                  end;
+           end;
+{$endif i386}
+         must_be_valid:=true;
+         firstpass(p^.right);
+         must_be_valid:=store_valid;
+         if codegenerror then
+           exit;
+
+       { some string functions don't need conversion, so treat them separatly }
+         if p^.left^.resulttype^.deftype=stringdef then
+          begin
+            if not (p^.right^.resulttype^.deftype in [stringdef,orddef]) then
+             begin
+               p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype);
+               firstpass(p^.right);
+               if codegenerror then
+                exit;
+             end;
+          { we call STRCOPY }
+            procinfo.flags:=procinfo.flags or pi_do_call;
+          end
+         else
+          begin
+            if (p^.right^.treetype=realconstn) then
+              begin
+                 if p^.left^.resulttype^.deftype=floatdef then
+                   begin
+                      case pfloatdef(p^.left^.resulttype)^.typ of
+                        s32real : p^.right^.realtyp:=ait_real_32bit;
+                        s64real : p^.right^.realtyp:=ait_real_64bit;
+                        s80real : p^.right^.realtyp:=ait_real_extended;
+                        { what about f32bit and s64bit }
+                      else
+                        begin
+                           p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype);
+
+                           { nochmal firstpass wegen der Typkonvertierung aufrufen }
+                           firstpass(p^.right);
+
+                           if codegenerror then
+                             exit;
+                        end;
+                      end;
+                   end;
+               end
+             else
+               begin
+                 p^.right:=gentypeconvnode(p^.right,p^.left^.resulttype);
+                 firstpass(p^.right);
+                 if codegenerror then
+                  exit;
+               end;
+          end;
+
+         if (aktexprlevel<4) then p^.resulttype:=voiddef
+           else p^.resulttype:=p^.right^.resulttype;
+         {
+           p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
+           p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
+         }
+         p^.registers32:=p^.left^.registers32+p^.right^.registers32;
+         p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
+      end;
+
+    procedure firstlr(var p : ptree);
+
+      begin
+         firstpass(p^.left);
+         firstpass(p^.right);
+      end;
+
+    procedure firstderef(var p : ptree);
+
+      begin
+         firstpass(p^.left);
+         if codegenerror then
+           exit;
+
+         p^.registers32:=max(p^.left^.registers32,1);
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+
+         if p^.left^.resulttype^.deftype<>pointerdef then
+          Message(cg_e_invalid_qualifier);
+
+         p^.resulttype:=ppointerdef(p^.left^.resulttype)^.definition;
+         p^.location.loc:=LOC_REFERENCE;
+      end;
+
+    procedure firstrange(var p : ptree);
+
+      var
+         ct : tconverttype;
+
+      begin
+         firstpass(p^.left);
+         firstpass(p^.right);
+         if codegenerror then
+           exit;
+         { allow only ordinal constants }
+         if not((p^.left^.treetype=ordconstn) and
+            (p^.right^.treetype=ordconstn)) then
+           Message(cg_e_illegal_expression);
+         { upper limit must be greater or equalt than lower limit }
+         { not if u32bit }
+         if (p^.left^.value>p^.right^.value) and
+            (( p^.left^.value<0) or (p^.right^.value>=0)) then
+           Message(cg_e_upper_lower_than_lower);
+         { both types must be compatible }
+         if not(isconvertable(p^.left^.resulttype,p^.right^.resulttype,
+           ct,ordconstn)) and
+           not(is_equal(p^.left^.resulttype,p^.right^.resulttype)) then
+           Message(sym_e_type_mismatch);
+      end;
+
+    procedure firstvecn(var p : ptree);
+
+      var
+         harr : pdef;
+         ct : tconverttype;
+
+
+      begin
+         firstpass(p^.left);
+         firstpass(p^.right);
+         if codegenerror then
+           exit;
+
+         { range check only for arrays }
+         if (p^.left^.resulttype^.deftype=arraydef) then
+           begin
+              if not(isconvertable(p^.right^.resulttype,
+                parraydef(p^.left^.resulttype)^.rangedef,
+                ct,ordconstn)) and
+              not(is_equal(p^.right^.resulttype,
+                parraydef(p^.left^.resulttype)^.rangedef)) then
+                Message(sym_e_type_mismatch);
+           end;
+         { Never convert a boolean or a char !}
+                 { maybe type conversion }
+                 if (p^.right^.resulttype^.deftype<>enumdef) and
+                  not ((p^.right^.resulttype^.deftype=orddef) and
+                  (Porddef(p^.right^.resulttype)^.typ in [bool8bit,uchar])) then
+                        begin
+                                p^.right:=gentypeconvnode(p^.right,s32bitdef);
+                                { once more firstpass }
+                                {?? It's better to only firstpass when the tree has
+                                 changed, isn't it ?}
+                                firstpass(p^.right);
+                        end;
+         if codegenerror then
+           exit;
+
+         { determine return type }
+         if p^.left^.resulttype^.deftype=arraydef then
+           p^.resulttype:=parraydef(p^.left^.resulttype)^.definition
+         else if (p^.left^.resulttype^.deftype=pointerdef) then
+           begin
+              { convert pointer to array }
+              harr:=new(parraydef,init(0,$7fffffff,s32bitdef));
+              parraydef(harr)^.definition:=ppointerdef(p^.left^.resulttype)^.definition;
+              p^.left:=gentypeconvnode(p^.left,harr);
+              firstpass(p^.left);
+
+              if codegenerror then
+                exit;
+              p^.resulttype:=parraydef(harr)^.definition
+           end
+         else
+         { indexed access to arrays }
+           p^.resulttype:=cchardef;
+
+         { the register calculation is easy if a const index is used }
+         if p^.right^.treetype=ordconstn then
+           p^.registers32:=p^.left^.registers32
+         else
+           begin
+              p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
+
+              { not correct, but what works better ? }
+              if p^.left^.registers32>0 then
+                p^.registers32:=max(p^.registers32,2)
+              else
+              { min. one register }
+                p^.registers32:=max(p^.registers32,1);
+           end;
+         p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
+         p^.location.loc:=p^.left^.location.loc;
+      end;
+
+    type
+       tfirstconvproc = procedure(var p : ptree);
+
+    procedure first_bigger_smaller(var p : ptree);
+
+      begin
+         if (p^.left^.location.loc<>LOC_REGISTER) and (p^.registers32=0) then
+           p^.registers32:=1;
+         p^.location.loc:=LOC_REGISTER;
+      end;
+
+    procedure first_cstring_charpointer(var p : ptree);
+
+      begin
+         p^.registers32:=1;
+         p^.location.loc:=LOC_REGISTER;
+      end;
+
+    procedure first_string_chararray(var p : ptree);
+
+           begin
+                   p^.registers32:=1;
+                   p^.location.loc:=LOC_REGISTER;
+           end;
+
+    procedure first_string_string(var p : ptree);
+
+      var l : longint;
+
+           begin
+                   if p^.left^.treetype=stringconstn then
+                     l:=length(pstring(p^.left^.value)^)
+                   else
+                     l:=pstringdef(p^.left^.resulttype)^.len;
+                   if l<>parraydef(p^.resulttype)^.highrange-parraydef(p^.resulttype)^.lowrange+1 then
+                     Message(sym_e_type_mismatch);
+           end;
+
+    procedure first_char_to_string(var p : ptree);
+
+      var
+         hp : ptree;
+
+      begin
+         if p^.left^.treetype=ordconstn then
+           begin
+              hp:=genstringconstnode(chr(p^.left^.value));
+              firstpass(hp);
+              disposetree(p);
+              p:=hp;
+           end
+         else
+           p^.location.loc:=LOC_MEM;
+      end;
+
+    procedure first_nothing(var p : ptree);
+
+      begin
+         p^.location.loc:=LOC_MEM;
+      end;
+
+    procedure first_array_to_pointer(var p : ptree);
+
+      begin
+         if p^.registers32<1 then
+           p^.registers32:=1;
+         p^.location.loc:=LOC_REGISTER;
+      end;
+
+    procedure first_int_real(var p : ptree);
+
+      var t : ptree;
+
+      begin
+         if p^.left^.treetype=ordconstn then
+           begin
+              { convert constants direct }
+              { not because of type conversion }
+              t:=genrealconstnode(p^.left^.value);
+              firstpass(t);
+              { the type can be something else than s64real !!}
+              t:=gentypeconvnode(t,p^.resulttype);
+              firstpass(t);
+              disposetree(p);
+              p:=t;
+              exit;
+           end
+         else
+           begin
+              if p^.registersfpu<1 then
+                p^.registersfpu:=1;
+              p^.location.loc:=LOC_FPU;
+           end;
+      end;
+
+    procedure first_int_fix(var p : ptree);
+
+      begin
+         if p^.left^.treetype=ordconstn then
+           begin
+              { convert constants direct }
+              p^.treetype:=fixconstn;
+              p^.valuef:=p^.left^.value shl 16;
+              p^.disposetyp:=dt_nothing;
+              disposetree(p^.left);
+              p^.location.loc:=LOC_MEM;
+           end
+         else
+           begin
+              if p^.registers32<1 then
+                p^.registers32:=1;
+                  p^.location.loc:=LOC_REGISTER;
+           end;
+      end;
+
+    procedure first_real_fix(var p : ptree);
+
+      begin
+         if p^.left^.treetype=realconstn then
+           begin
+              { convert constants direct }
+              p^.treetype:=fixconstn;
+              p^.valuef:=round(p^.left^.valued*65536);
+              p^.disposetyp:=dt_nothing;
+              disposetree(p^.left);
+              p^.location.loc:=LOC_MEM;
+           end
+         else
+           begin
+              { at least one fpu and int register needed }
+              if p^.registers32<1 then
+                p^.registers32:=1;
+              if p^.registersfpu<1 then
+                p^.registersfpu:=1;
+              p^.location.loc:=LOC_REGISTER;
+           end;
+      end;
+
+    procedure first_fix_real(var p : ptree);
+
+      begin
+         if p^.left^.treetype=fixconstn then
+           begin
+              { convert constants direct }
+              p^.treetype:=realconstn;
+              p^.valued:=round(p^.left^.valuef/65536.0);
+              p^.disposetyp:=dt_nothing;
+              disposetree(p^.left);
+              p^.location.loc:=LOC_MEM;
+           end
+         else
+           begin
+              if p^.registersfpu<1 then
+                p^.registersfpu:=1;
+                  p^.location.loc:=LOC_FPU;
+           end;
+    end;
+
+    procedure first_real_real(var p : ptree);
+
+      begin
+         if p^.registersfpu<1 then
+           p^.registersfpu:=1;
+         p^.location.loc:=LOC_FPU;
+      end;
+
+    procedure first_pointer_to_array(var p : ptree);
+
+      begin
+         if p^.registers32<1 then
+           p^.registers32:=1;
+         p^.location.loc:=LOC_REFERENCE;
+      end;
+
+    procedure first_chararray_string(var p : ptree);
+
+      begin
+         { the only important information is the location of the }
+         { result                                                }
+         { other stuff is done by firsttypeconv                  }
+         p^.location.loc:=LOC_MEM;
+      end;
+
+    procedure first_cchar_charpointer(var p : ptree);
+
+      begin
+         p^.left:=gentypeconvnode(p^.left,cstringdef);
+         { convert constant char to constant string }
+         firstpass(p^.left);
+         { evalute tree }
+         firstpass(p);
+      end;
+
+    procedure first_locmem(var p : ptree);
+
+      begin
+         p^.location.loc:=LOC_MEM;
+      end;
+
+    procedure first_bool_byte(var p : ptree);
+
+       begin
+          p^.location.loc:=LOC_REGISTER;
+          { Florian I think this is overestimated
+            but I still do not really understand how to get this right (PM) }
+          { Hmmm, I think we need only one reg to return the result of      }
+          { this node => so
+          if p^.registers32<1 then
+            p^.registers32:=1;
+            should work (FK)
+          }
+          p^.registers32:=p^.left^.registers32+1;
+       end;
+
+    procedure first_proc_to_procvar(var p : ptree);
+
+      var
+         hp : ptree;
+         hp2 : pdefcoll;
+
+      begin
+         firstpass(p^.left);
+         if codegenerror then
+           exit;
+
+         if (p^.left^.location.loc<>LOC_REFERENCE) then
+           Message(cg_e_illegal_expression);
+
+         p^.registers32:=p^.left^.registers32;
+         if p^.registers32<1 then
+           p^.registers32:=1;
+         p^.location.loc:=LOC_REGISTER;
+      end;
+
+        function is_procsym_load(p:Ptree):boolean;
+
+        begin
+           is_procsym_load:=((p^.treetype=loadn) and (p^.symtableentry^.typ=procsym)) or
+                            ((p^.treetype=addrn) and (p^.left^.treetype=loadn)
+                            and (p^.left^.symtableentry^.typ=procsym)) ;
+        end;
+
+   { change a proc call to a procload for assignment to a procvar }
+   { this can only happen for proc/function without arguments }
+        function is_procsym_call(p:Ptree):boolean;
+
+        begin
+           is_procsym_call:=(p^.treetype=calln) and (p^.left=nil) and
+             (((p^.symtableprocentry^.typ=procsym) and (p^.right=nil)) or
+             ((p^.right<>nil) and (p^.right^.symtableprocentry^.typ=varsym)));
+        end;
+{***}
+
+     function is_assignment_overloaded(from_def,to_def : pdef) : boolean;
+       var
+          passproc : pprocdef;
+       begin
+          is_assignment_overloaded:=false;
+          if assigned(overloaded_operators[assignment]) then
+            passproc:=overloaded_operators[assignment]^.definition
+          else
+            passproc:=nil;
+          while passproc<>nil do
+            begin
+              if (passproc^.retdef=to_def) and (passproc^.para1^.data=from_def) then
+                begin
+                   is_assignment_overloaded:=true;
+                   break;
+                end;
+              passproc:=passproc^.nextoverloaded;
+            end;
+       end;
+    { Attention: do *** no ***  recursive call of firstpass }
+    { because the child tree is always passed               }
+
+        procedure firsttypeconv(var p : ptree);
+
+          var
+                 hp : ptree;
+                 hp2,hp3:Pdefcoll;
+                 aprocdef : pprocdef;
+                 proctype : tdeftype;
+
+    const
+       firstconvert : array[tc_u8bit_2_s32bit..tc_cchar_charpointer] of
+         tfirstconvproc = (first_bigger_smaller,first_nothing,first_bigger_smaller,
+                           first_bigger_smaller,first_bigger_smaller,
+                           first_bigger_smaller,first_bigger_smaller,
+                           first_bigger_smaller,first_locmem,
+                           first_cstring_charpointer,first_string_chararray,
+                           first_array_to_pointer,first_pointer_to_array,
+                           first_char_to_string,first_bigger_smaller,
+                           first_bigger_smaller,first_bigger_smaller,
+                           first_bigger_smaller,first_bigger_smaller,
+                           first_bigger_smaller,first_bigger_smaller,
+                           first_bigger_smaller,first_bigger_smaller,
+                           first_bigger_smaller,first_bigger_smaller,
+                           first_bigger_smaller,first_bigger_smaller,
+                           first_bigger_smaller,first_bigger_smaller,
+                           first_int_real,first_real_fix,
+                           first_fix_real,first_int_fix,first_real_real,
+                           first_locmem,first_bool_byte,first_proc_to_procvar,
+               first_cchar_charpointer);
+
+    begin
+       aprocdef:=nil;
+       { if explicite type conversation, then run firstpass }
+       if p^.explizit then
+         firstpass(p^.left);
+
+       if codegenerror then
+         exit;
+
+       { remove obsolete type conversions }
+       if is_equal(p^.left^.resulttype,p^.resulttype) then
+         begin
+            hp:=p;
+            p:=p^.left;
+            p^.resulttype:=hp^.resulttype;
+            putnode(hp);
+            exit;
+         end;
+       p^.registers32:=p^.left^.registers32;
+       p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+       p^.registersmmx:=p^.left^.registersmmx;
+{$endif}
+       set_location(p^.location,p^.left^.location);
+       if (not(isconvertable(p^.left^.resulttype,p^.resulttype,p^.convtyp,p^.left^.treetype))) then
+         begin
+            if is_assignment_overloaded(p^.left^.resulttype,p^.resulttype) then
+              begin
+                 procinfo.flags:=procinfo.flags or pi_do_call;
+                 hp:=gencallnode(overloaded_operators[assignment],nil);
+                 hp^.left:=gencallparanode(p^.left,nil);
+                 putnode(p);
+                 p:=hp;
+                 firstpass(p);
+                 exit;
+              end;
+           {Procedures have a resulttype of voiddef and functions of their
+           own resulttype. They will therefore always be incompatible with
+           a procvar. Because isconvertable cannot check for procedures we
+           use an extra check for them.}
+           if (cs_tp_compatible in aktswitches) and
+             ((is_procsym_load(p^.left) or is_procsym_call(p^.left)) and
+             (p^.resulttype^.deftype=procvardef)) then
+             begin
+                { just a test: p^.explizit:=false; }
+                if is_procsym_call(p^.left) then
+                  begin
+                     if p^.left^.right=nil then
+                       begin
+                          p^.left^.treetype:=loadn;
+                          { are at same offset so this could be spared, but
+                          it more secure to do it anyway }
+                          p^.left^.symtableentry:=p^.left^.symtableprocentry;
+                          p^.left^.resulttype:=pprocsym(p^.left^.symtableentry)^.definition;
+                          aprocdef:=pprocdef(p^.left^.resulttype);
+                       end
+                     else
+                       begin
+                          p^.left^.right^.treetype:=loadn;
+                          p^.left^.right^.symtableentry:=p^.left^.right^.symtableentry;
+                          P^.left^.right^.resulttype:=pvarsym(p^.left^.symtableentry)^.definition;
+                          hp:=p^.left^.right;
+                          putnode(p^.left);
+                          p^.left:=hp;
+                          { should we do that ? }
+                          firstpass(p^.left);
+                          if not is_equal(p^.left^.resulttype,p^.resulttype) then
+                            begin
+                               Message(sym_e_type_mismatch);
+                               exit;
+                            end
+                          else
+                            begin
+                               hp:=p;
+                               p:=p^.left;
+                               p^.resulttype:=hp^.resulttype;
+                               putnode(hp);
+                               exit;
+                            end;
+                       end;
+                  end
+                else
+                  begin
+                     if p^.left^.treetype=addrn then
+                       begin
+                          hp:=p^.left;
+                          p^.left:=p^.left^.left;
+                          putnode(p^.left);
+                       end
+                     else
+                       aprocdef:=pprocsym(p^.left^.symtableentry)^.definition;
+                  end;
+
+                p^.convtyp:=tc_proc2procvar;
+                { Now check if the procedure we are going to assign to
+                  the procvar,  is compatible with the procvar's type.
+                  Did the original procvar support do such a check?
+                  I can't find any.}
+                { answer : is_equal works for procvardefs !! }
+                { but both must be procvardefs, so we cheet  little }
+                if assigned(aprocdef) then
+                  begin
+                    proctype:=aprocdef^.deftype;
+                    aprocdef^.deftype:=procvardef;
+
+                    if not is_equal(aprocdef,p^.resulttype) then
+                      begin
+                        aprocdef^.deftype:=proctype;
+                        Message(sym_e_type_mismatch);
+                      end;
+                    aprocdef^.deftype:=proctype;
+                    firstconvert[p^.convtyp](p);
+                  end
+                else
+                  Message(sym_e_type_mismatch);
+                exit;
+             end
+           else
+             begin
+                if p^.explizit then
+                  begin
+                     { boolean to byte are special because the
+                       location can be different }
+                     if (p^.resulttype^.deftype=orddef) and
+                        (porddef(p^.resulttype)^.typ=u8bit) and
+                        (p^.left^.resulttype^.deftype=orddef) and
+                        (porddef(p^.left^.resulttype)^.typ=bool8bit) then
+                       begin
+                          p^.convtyp:=tc_bool_2_u8bit;
+                          firstconvert[p^.convtyp](p);
+                          exit;
+                       end;
+                     { normal tc_equal-Konvertierung durchf�hren }
+                     p^.convtyp:=tc_equal;
+                     { wenn Aufz„hltyp nach Ordinal konvertiert werden soll }
+                     { dann Aufz„hltyp=s32bit                               }
+                     if (p^.left^.resulttype^.deftype=enumdef) and
+                        is_ordinal(p^.resulttype) then
+                       begin
+                          if p^.left^.treetype=ordconstn then
+                            begin
+                               hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
+                               disposetree(p);
+                               p:=hp;
+                               exit;
+                            end
+                          else
+                            begin
+                               if not isconvertable(s32bitdef,p^.resulttype,p^.convtyp,ordconstn { nur Dummy} ) then
+                                 Message(cg_e_illegal_type_conversion);
+                            end;
+
+                       end
+                     { ordinal to enumeration }
+                     else
+                       if (p^.resulttype^.deftype=enumdef) and
+                          is_ordinal(p^.left^.resulttype) then
+                         begin
+                            if p^.left^.treetype=ordconstn then
+                              begin
+                                 hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
+                                 disposetree(p);
+                                 p:=hp;
+                                 exit;
+                              end
+                            else
+                              begin
+                                 if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn { nur Dummy} ) then
+                                   Message(cg_e_illegal_type_conversion);
+                              end;
+                         end
+                     {Are we typecasting an ordconst to a char?}
+                     else
+                       if is_equal(p^.resulttype,cchardef) and
+                          is_ordinal(p^.left^.resulttype) then
+                         begin
+                            if p^.left^.treetype=ordconstn then
+                              begin
+                                 hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
+                                 disposetree(p);
+                                 p:=hp;
+                                 exit;
+                              end
+                            else
+                              begin
+                                 { this is wrong because it converts to a 4 byte long var !!
+                                   if not isconvertable(p^.left^.resulttype,s32bitdef,p^.convtyp,ordconstn  nur Dummy ) then }
+                                 if not isconvertable(p^.left^.resulttype,u8bitdef,p^.convtyp,ordconstn { nur Dummy} ) then
+                                   Message(cg_e_illegal_type_conversion);
+                              end;
+                         end
+                     { only if the same size or formal def }
+                     { why do we allow typecasting of voiddef ?? (PM) }
+                     else
+                       if not(
+                             (p^.left^.resulttype^.deftype=formaldef) or
+                             (p^.left^.resulttype^.size=p^.resulttype^.size) or
+                             (is_equal(p^.left^.resulttype,voiddef)  and
+                             (p^.left^.treetype=derefn))
+                             ) then
+                         Message(cg_e_illegal_type_conversion);
+                     { the conversion into a strutured type is only }
+                     { possible, if the source is no register         }
+                     if (p^.resulttype^.deftype in [recorddef,stringdef,arraydef,objectdef]) and
+                        (p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+                       Message(cg_e_illegal_type_conversion);
+                end
+              else
+                Message(sym_e_type_mismatch);
+           end
+         end
+       else
+         begin
+            { just a test: p^.explizit:=false; }
+            { ordinale contants are direct converted }
+            if (p^.left^.treetype=ordconstn) and is_ordinal(p^.resulttype) then
+              begin
+                 { perform range checking }
+                 if not(p^.explizit and (cs_tp_compatible in aktswitches)) then
+                   testrange(p^.resulttype,p^.left^.value);
+                 hp:=genordinalconstnode(p^.left^.value,p^.resulttype);
+                 disposetree(p);
+                 p:=hp;
+                 exit;
+              end;
+            if p^.convtyp<>tc_equal then
+              firstconvert[p^.convtyp](p);
+         end;
+    end;
+
+    { *************** subroutine handling **************** }
+
+    procedure firstcallparan(var p : ptree;defcoll : pdefcoll);
+
+      var store_valid : boolean;
+          convtyp     : tconverttype;
+      begin
+         inc(parsing_para_level);
+         if assigned(p^.right) then
+           begin
+              if defcoll=nil then
+                firstcallparan(p^.right,nil)
+              else
+                firstcallparan(p^.right,defcoll^.next);
+              p^.registers32:=p^.right^.registers32;
+              p^.registersfpu:=p^.right^.registersfpu;
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=p^.right^.registersmmx;
+{$endif}
+           end;
+         if defcoll=nil then
+           begin
+              firstpass(p^.left);
+
+              if codegenerror then
+                begin
+                   dec(parsing_para_level);
+                   exit;
+                end;
+
+              p^.resulttype:=p^.left^.resulttype;
+           end
+         { if we know the routine which is called, then the type }
+         { conversions are inserted                            }
+         else
+           begin
+               if count_ref then
+                     begin
+                     store_valid:=must_be_valid;
+                     if (defcoll^.paratyp<>vs_var) then
+                       must_be_valid:=true
+                     else
+                       must_be_valid:=false;
+                     { here we must add something for the implicit type }
+                     { conversion from array of char to pchar }
+                     if isconvertable(p^.left^.resulttype,defcoll^.data,convtyp,p^.left^.treetype) then
+                       if convtyp=tc_array_to_pointer then
+                         must_be_valid:=false;
+                     firstpass(p^.left);
+                     must_be_valid:=store_valid;
+                     End;
+              if not((p^.left^.resulttype^.deftype=stringdef) and
+                     (defcoll^.data^.deftype=stringdef)) and
+                     (defcoll^.data^.deftype<>formaldef) then
+                begin
+                   if (defcoll^.paratyp=vs_var) and
+                   { allows conversion from word to integer and
+                     byte to shortint }
+                     (not(
+                        (p^.left^.resulttype^.deftype=orddef) and
+                        (defcoll^.data^.deftype=orddef) and
+                        (p^.left^.resulttype^.size=defcoll^.data^.size)
+                         ) and
+                   { an implicit pointer conversion is allowed }
+                     not(
+                        (p^.left^.resulttype^.deftype=pointerdef) and
+                        (defcoll^.data^.deftype=pointerdef)
+                         ) and
+                   { an implicit file conversion is also allowed }
+                   { from a typed file to an untyped one           }
+                     not(
+                        (p^.left^.resulttype^.deftype=filedef) and
+                        (defcoll^.data^.deftype=filedef) and
+                        (pfiledef(defcoll^.data)^.filetype = ft_untyped) and
+                        (pfiledef(p^.left^.resulttype)^.filetype = ft_typed)
+                         ) and
+                     not(is_equal(p^.left^.resulttype,defcoll^.data))) then
+                       Message(parser_e_call_by_ref_without_typeconv);
+                   { don't generate an type conversion for open arrays }
+                   { else we loss the ranges                             }
+                   if not(is_open_array(defcoll^.data)) then
+                     begin
+                        p^.left:=gentypeconvnode(p^.left,defcoll^.data);
+                        firstpass(p^.left);
+                     end;
+                   if codegenerror then
+                     begin
+                        dec(parsing_para_level);
+                        exit;
+                     end;
+                end;
+              { check var strings }
+              if (cs_strict_var_strings in aktswitches) and
+                 (p^.left^.resulttype^.deftype=stringdef) and
+                 (defcoll^.data^.deftype=stringdef) and
+                 (defcoll^.paratyp=vs_var) and
+                 not(is_equal(p^.left^.resulttype,defcoll^.data)) then
+                 Message(parser_e_strict_var_string_violation);
+              { Variablen, die call by reference �bergeben werden, }
+              { k”nnen nicht in ein Register kopiert werden       }
+              { is this usefull here ? }
+              { this was missing in formal parameter list   }
+              if defcoll^.paratyp=vs_var then
+                make_not_regable(p^.left);
+
+              p^.resulttype:=defcoll^.data;
+           end;
+         if p^.left^.registers32>p^.registers32 then
+           p^.registers32:=p^.left^.registers32;
+         if p^.left^.registersfpu>p^.registersfpu then
+           p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         if p^.left^.registersmmx>p^.registersmmx then
+           p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+         dec(parsing_para_level);
+      end;
+
+    procedure firstcalln(var p : ptree);
+
+      type
+         pprocdefcoll = ^tprocdefcoll;
+
+         tprocdefcoll = record
+            data : pprocdef;
+            nextpara : pdefcoll;
+            firstpara : pdefcoll;
+            next : pprocdefcoll;
+         end;
+
+      var
+         hp,procs,hp2 : pprocdefcoll;
+         pd : pprocdef;
+         st : psymtable;
+         actprocsym : pprocsym;
+         def_from,def_to,conv_to : pdef;
+         pt : ptree;
+         exactmatch : boolean;
+         paralength,l : longint;
+         pdc : pdefcoll;
+
+         { only Dummy }
+         hcvt : tconverttype;
+         regi : tregister;
+         store_valid, old_count_ref : boolean;
+
+
+      { types.is_equal can't handle a formaldef ! }
+      function is_equal(def1,def2 : pdef) : boolean;
+
+        begin
+           { all types can be passed to a  formaldef  }
+           is_equal:=(def1^.deftype=formaldef) or
+             (assigned(def2) and types.is_equal(def1,def2));
+        end;
+
+      function is_in_limit(def_from,def_to : pdef) : boolean;
+
+        begin
+           is_in_limit:=(def_from^.deftype = orddef) and
+                        (def_to^.deftype = orddef) and
+                        (porddef(def_from)^.von>porddef(def_to)^.von) and
+                        (porddef(def_from)^.bis<porddef(def_to)^.bis);
+        end;
+
+
+      begin
+         { release registers! }
+         { if procdefinition<>nil then we called firstpass already }
+         { it seems to be bad because of the registers }
+         { at least we can avoid the overloaded search !! }
+         procs:=nil;
+         { made this global for disposing !! }
+         store_valid:=must_be_valid;
+         if not assigned(p^.procdefinition) then
+           begin
+              must_be_valid:=false;
+              { procedure variable ? }
+              if not(assigned(p^.right)) then
+                begin
+                   if assigned(p^.left) then
+                     begin
+                        old_count_ref:=count_ref;
+                        count_ref:=false;
+                        store_valid:=must_be_valid;
+                        must_be_valid:=false;
+                        firstcallparan(p^.left,nil);
+                        count_ref:=old_count_ref;
+                        must_be_valid:=store_valid;
+                        if codegenerror then
+                          exit;
+                     end;
+                   { determine length of parameter list }
+                   pt:=p^.left;
+                   paralength:=0;
+                   while assigned(pt) do
+                     begin
+                        inc(paralength);
+                        pt:=pt^.right;
+                     end;
+
+                   { alle in Frage kommenden Prozeduren in eine }
+                   { verkettete Liste einf�gen                  }
+                   actprocsym:=p^.symtableprocentry;
+                   pd:=actprocsym^.definition;
+                   while assigned(pd) do
+                     begin
+                        { we should also check that the overloaded function
+                        has been declared in a unit that is in the uses !! }
+                        { pd^.owner should be in the symtablestack !! }
+                        { Laenge der deklarierten Parameterliste feststellen: }
+                        { not necessary why nextprocsym field }
+                        {st:=symtablestack;
+                        if (pd^.owner^.symtabletype<>objectsymtable) then
+                          while assigned(st) do
+                            begin
+                               if (st=pd^.owner) then break;
+                               st:=st^.next;
+                            end;
+                        if assigned(st) then }
+                          begin
+                             pdc:=pd^.para1;
+                             l:=0;
+                             while assigned(pdc) do
+                               begin
+                                  inc(l);
+                                  pdc:=pdc^.next;
+                               end;
+                             { nur wenn die Parameterl„nge paát, dann Einf�gen }
+                             if l=paralength then
+                               begin
+                                  new(hp);
+                                  hp^.data:=pd;
+                                  hp^.next:=procs;
+                                  hp^.nextpara:=pd^.para1;
+                                  hp^.firstpara:=pd^.para1;
+                                  procs:=hp;
+                               end;
+                          end;
+                        pd:=pd^.nextoverloaded;
+{$ifdef CHAINPROCSYMS}
+                        if (pd=nil) and not (p^.unit_specific) then
+                          begin
+                             actprocsym:=actprocsym^.nextprocsym;
+                             if assigned(actprocsym) then
+                               pd:=actprocsym^.definition;
+                          end;
+{$endif CHAINPROCSYMS}
+                     end;
+
+                   { nun alle Parameter nacheinander vergleichen }
+                   pt:=p^.left;
+                   while assigned(pt) do
+                     begin
+                        { matches a parameter of one procedure exact ? }
+                        exactmatch:=false;
+                        hp:=procs;
+                        while assigned(hp) do
+                          begin
+                             if is_equal(hp^.nextpara^.data,pt^.resulttype) then
+                               begin
+                                  if hp^.nextpara^.data=pt^.resulttype then
+                                    begin
+                                       pt^.exact_match_found:=true;
+                                       hp^.nextpara^.argconvtyp:=act_exact;
+                                    end
+                                  else
+                                    hp^.nextpara^.argconvtyp:=act_equal;
+                                  exactmatch:=true;
+                               end
+                             else
+                               hp^.nextpara^.argconvtyp:=act_convertable;
+                             hp:=hp^.next;
+                          end;
+
+                        { .... if yes, del all the other procedures }
+                        if exactmatch then
+                          begin
+                             { the first .... }
+                             while (assigned(procs)) and not(is_equal(procs^.nextpara^.data,pt^.resulttype)) do
+                               begin
+                                  hp:=procs^.next;
+                                  dispose(procs);
+                                  procs:=hp;
+                               end;
+                             { and the others }
+                             hp:=procs;
+                             while (assigned(hp)) and assigned(hp^.next) do
+                               begin
+                                  if not(is_equal(hp^.next^.nextpara^.data,pt^.resulttype)) then
+                                    begin
+                                       hp2:=hp^.next^.next;
+                                       dispose(hp^.next);
+                                       hp^.next:=hp2;
+                                    end
+                                  else
+                                    hp:=hp^.next;
+                               end;
+                          end
+                        { sollte nirgendwo ein Parameter exakt passen, }
+                        { so alle Prozeduren entfernen, bei denen      }
+                        { der Parameter auch nach einer impliziten     }
+                        { Typkonvertierung nicht passt                 }
+                        else
+                          begin
+                             { erst am Anfang }
+                             while (assigned(procs)) and
+                               not(isconvertable(pt^.resulttype,procs^.nextpara^.data,hcvt,pt^.left^.treetype)) do
+                               begin
+                                  hp:=procs^.next;
+                                  dispose(procs);
+                                  procs:=hp;
+                               end;
+                             { und jetzt aus der Mitte }
+                             hp:=procs;
+                             while (assigned(hp)) and assigned(hp^.next) do
+                               begin
+                                  if not(isconvertable(pt^.resulttype,hp^.next^.nextpara^.data,
+                                    hcvt,pt^.left^.treetype)) then
+                                    begin
+                                       hp2:=hp^.next^.next;
+                                       dispose(hp^.next);
+                                       hp^.next:=hp2;
+                                    end
+                                  else
+                                    hp:=hp^.next;
+                               end;
+                          end;
+                        { nun bei denn Prozeduren den nextpara-Zeiger auf den }
+                        { naechsten Parameter setzen                          }
+                        hp:=procs;
+                        while assigned(hp) do
+                          begin
+                             hp^.nextpara:=hp^.nextpara^.next;
+                             hp:=hp^.next;
+                          end;
+                        pt:=pt^.right;
+                     end;
+
+                   if procs=nil then
+                     if (parsing_para_level=0) or (p^.left<>nil) then
+                       begin
+                          Message(parser_e_illegal_parameter_list);
+                          exit;
+                       end
+                     else
+                       begin
+                          { try to convert to procvar }
+                          p^.treetype:=loadn;
+                          p^.resulttype:=pprocsym(p^.symtableprocentry)^.definition;
+                          p^.symtableentry:=p^.symtableprocentry;
+                          p^.is_first:=false;
+                          p^.disposetyp:=dt_nothing;
+                          firstpass(p);
+                          exit;
+                       end;
+
+                   { if there are several choices left then for orddef }
+                   { if a type is totally included in the other        }
+                   { we don't fear an overflow ,                       }
+                   { so we can do as if it is an exact match           }
+                   { this will convert integer to longint              }
+                   { rather than to words                              }
+                   { conversion of byte to integer or longint          }
+                   {would still not be solved                          }
+                   if assigned(procs^.next) then
+                     begin
+                        hp:=procs;
+                        while assigned(hp) do
+                          begin
+                            hp^.nextpara:=hp^.firstpara;
+                            hp:=hp^.next;
+                          end;
+                        pt:=p^.left;
+                        while assigned(pt) do
+                          begin
+                             { matches a parameter of one procedure exact ? }
+                             exactmatch:=false;
+                             def_from:=pt^.resulttype;
+                             hp:=procs;
+                             while assigned(hp) do
+                               begin
+                                  if not is_equal(hp^.nextpara^.data,pt^.resulttype) then
+                                    begin
+                                       def_to:=hp^.nextpara^.data;
+                                       if (def_from^.deftype=orddef) and (def_to^.deftype=orddef) then
+                                         if is_in_limit(def_from,def_to) or
+                                           ((hp^.nextpara^.paratyp=vs_var) and
+                                           (def_from^.size=def_to^.size)) then
+                                           begin
+                                              exactmatch:=true;
+                                              conv_to:=def_to;
+                                           end;
+                                    end;
+                                  hp:=hp^.next;
+                               end;
+
+                             { .... if yes, del all the other procedures }
+                             if exactmatch then
+                               begin
+                                  { the first .... }
+                                  while (assigned(procs)) and not(is_in_limit(def_from,procs^.nextpara^.data)) do
+                                    begin
+                                       hp:=procs^.next;
+                                       dispose(procs);
+                                       procs:=hp;
+                                    end;
+                                  { and the others }
+                                  hp:=procs;
+                                  while (assigned(hp)) and assigned(hp^.next) do
+                                    begin
+                                       if not(is_in_limit(def_from,hp^.next^.nextpara^.data)) then
+                                         begin
+                                            hp2:=hp^.next^.next;
+                                            dispose(hp^.next);
+                                            hp^.next:=hp2;
+                                         end
+                                       else
+                                         begin
+                                           def_to:=hp^.next^.nextpara^.data;
+                                           if (conv_to^.size>def_to^.size) or
+                                              ((porddef(conv_to)^.von<porddef(def_to)^.von) and
+                                              (porddef(conv_to)^.bis>porddef(def_to)^.bis)) then
+                                             begin
+                                                hp2:=procs;
+                                                procs:=hp;
+                                                conv_to:=def_to;
+                                                dispose(hp2);
+                                             end
+                                           else
+                                             hp:=hp^.next;
+                                         end;
+                                    end;
+                               end;
+                             { nun bei denn Prozeduren den nextpara-Zeiger auf den }
+                             { naechsten Parameter setzen                          }
+                             hp:=procs;
+                             while assigned(hp) do
+                               begin
+                                  hp^.nextpara:=hp^.nextpara^.next;
+                                  hp:=hp^.next;
+                               end;
+                             pt:=pt^.right;
+                          end;
+                     end;
+                   { let's try to eliminate equal is exact is there }
+                   {if assigned(procs^.next) then
+                     begin
+                        pt:=p^.left;
+                        while assigned(pt) do
+                          begin
+                             if pt^.exact_match_found then
+                               begin
+                                  hp:=procs;
+                                  while (assigned(procs)) and (procs^.nextpara^.data<>pt^.resulttype) do
+                                    begin
+                                       hp:=procs^.next;
+                                       dispose(procs);
+                                       procs:=hp;
+                                    end;
+                               end;
+                             pt:=pt^.right;
+                          end;
+                     end; }
+
+{$ifndef CHAINPROCSYMS}
+                   if assigned(procs^.next) then
+                     Message(cg_e_cant_choose_overload_function);
+{$else CHAINPROCSYMS}
+                   if assigned(procs^.next) then
+                     { if the last retained is the only one }
+                     { from a unit it is OK              PM  }
+                     { the last is the one coming from the first symtable }
+                     { as the diff defcoll are inserted in front }
+                     begin
+                        hp2:=procs;
+                        while assigned(hp2^.next) and assigned(hp2^.next^.next) do
+                          hp2:=hp2^.next;
+                        if (hp2^.data^.owner<>hp2^.next^.data^.owner) then
+                          begin
+                             hp:=procs^.next;
+                             {hp2 is the correct one }
+                             hp2:=hp2^.next;
+                             while hp<>hp2 do
+                               begin
+                                 dispose(procs);
+                                 procs:=hp;
+                                 hp:=procs^.next;
+                               end;
+                             procs:=hp2;
+                          end
+                        else
+                          Message(cg_e_cant_choose_overload_function);
+                          error(too_much_matches);
+                     end;
+{$endif CHAINPROCSYMS}
+     {$ifdef UseBrowser}
+                   add_new_ref(procs^.data^.lastref);
+     {$endif UseBrowser}
+                   p^.procdefinition:=procs^.data;
+                   p^.resulttype:=procs^.data^.retdef;
+                   p^.location.loc:=LOC_MEM;
+{$ifdef CHAINPROCSYMS}
+                   { object with method read;
+                     call to read(x) will be a usual procedure call }
+                   if assigned(p^.methodpointer) and
+                     (p^.procdefinition^._class=nil) then
+                     begin
+                        { not ok for extended }
+                        case p^.methodpointer^.treetype of
+                           typen,hnewn : fatalerror(no_para_match);
+                        end;
+                        disposetree(p^.methodpointer);
+                        p^.methodpointer:=nil;
+                     end;
+{$endif CHAINPROCSYMS}
+
+                   { work trough all parameters to insert the type conversions }
+                   if assigned(p^.left) then
+                     begin
+                        old_count_ref:=count_ref;
+                        count_ref:=true;
+                        firstcallparan(p^.left,p^.procdefinition^.para1);
+                        count_ref:=old_count_ref;
+                     end;
+                   { handle predefined procedures }
+                   if (p^.procdefinition^.options and pointernproc)<>0 then
+                     begin
+                        { settextbuf needs two args }
+                        if assigned(p^.left^.right) then
+                          pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,p^.left)
+                        else
+                          begin
+                             pt:=geninlinenode(pprocdef(p^.procdefinition)^.extnumber,p^.left^.left);
+                             putnode(p^.left);
+                          end;
+                        putnode(p);
+                        firstpass(pt);
+                        { was placed after the exit          }
+                        { caused GPF                         }
+                        { error caused and corrected by (PM) }
+                        p:=pt;
+
+                        must_be_valid:=store_valid;
+                        if codegenerror then
+                          exit;
+
+                        dispose(procs);
+                        exit;
+                     end
+                   else
+                     { no intern procedure => we do a call }
+                     procinfo.flags:=procinfo.flags or pi_do_call;
+
+                   { calc the correture value for the register }
+{$ifdef i386}
+                   { calc the correture value for the register }
+                   for regi:=R_EAX to R_EDI do
+                     begin
+                        if (p^.procdefinition^.usedregisters and ($80 shr word(regi)))<>0 then
+                          inc(reg_pushes[regi],t_times*2);
+                     end;
+{$endif}
+{$ifdef m68k}
+                  for regi:=R_D0 to R_A6 do
+                    begin
+                       if (p^.procdefinition^.usedregisters and ($800 shr word(regi)))<>0 then
+                         inc(reg_pushes[regi],t_times*2);
+                    end;
+{$endif}
+                end
+              else
+                begin
+                   { procedure variable }
+                   { die Typen der Parameter berechnen }
+
+                   { procedure does a call }
+                   procinfo.flags:=procinfo.flags or pi_do_call;
+
+{$ifdef i386}
+                   { calc the correture value for the register }
+                   for regi:=R_EAX to R_EDI do
+                     inc(reg_pushes[regi],t_times*2);
+{$endif}
+{$ifdef m68k}
+                   { calc the correture value for the register }
+                   for regi:=R_D0 to R_A6 do
+                     inc(reg_pushes[regi],t_times*2);
+{$endif}
+                   if assigned(p^.left) then
+                     begin
+                        old_count_ref:=count_ref;
+                        count_ref:=false;
+                        firstcallparan(p^.left,nil);
+                        count_ref:=old_count_ref;
+                        if codegenerror then
+                          exit;
+                     end;
+                   firstpass(p^.right);
+
+                   { check the parameters }
+                   pdc:=pprocvardef(p^.right^.resulttype)^.para1;
+                   pt:=p^.left;
+                   while assigned(pdc) and assigned(pt) do
+                     begin
+                        pt:=pt^.right;
+                        pdc:=pdc^.next;
+                     end;
+                   if assigned(pt) or assigned(pdc) then
+                    Message(parser_e_illegal_parameter_list);
+
+                   { insert type conversions }
+                   if assigned(p^.left) then
+                     begin
+                        old_count_ref:=count_ref;
+                        count_ref:=true;
+                        firstcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1);
+                        count_ref:=old_count_ref;
+                        if codegenerror then
+                          exit;
+                     end;
+                   p^.resulttype:=pprocvardef(p^.right^.resulttype)^.retdef;
+                   { this was missing , leads to a bug below if
+                     the procvar is a function }
+                   p^.procdefinition:=pprocdef(p^.right^.resulttype);
+                end;
+         end; { not assigned(p^.procdefinition) }
+
+         { get a register for the return value }
+         if (p^.resulttype<>pdef(voiddef)) then
+           begin
+              { the constructor returns the result with the flags }
+              if (p^.procdefinition^.options and poconstructor)<>0 then
+                begin
+                   { extra handling of classes }
+                   { p^.methodpointer should be assigned! }
+                   if assigned(p^.methodpointer) and assigned(p^.methodpointer^.resulttype) and
+                     (p^.methodpointer^.resulttype^.deftype=classrefdef) then
+                     begin
+                        p^.location.loc:=LOC_REGISTER;
+                        p^.registers32:=1;
+                     end
+                   else
+                     p^.location.loc:=LOC_FLAGS;
+                end
+              else
+                begin
+{$ifdef SUPPORT_MMX}
+                   if (cs_mmx in aktswitches) and
+                     is_mmx_able_array(p^.resulttype) then
+                     begin
+                        p^.location.loc:=LOC_MMXREGISTER;
+                        p^.registersmmx:=1;
+                     end
+                   else
+{$endif SUPPORT_MMX}
+                   if ret_in_acc(p^.resulttype) then
+                     begin
+                        p^.location.loc:=LOC_REGISTER;
+                        p^.registers32:=1;
+                     end
+                   else if (p^.resulttype^.deftype=floatdef) then
+                     begin
+                        p^.location.loc:=LOC_FPU;
+                        p^.registersfpu:=1;
+                     end
+                end;
+           end;
+
+         { if this is a call to a method calc the registers }
+         if (p^.methodpointer<>nil) then
+           begin
+              case p^.methodpointer^.treetype of
+                { but only, if this is not a supporting node }
+                typen,hnewn : ;
+                else
+                  begin
+                     { R.Assign is not a constructor !!! }
+                     { but for R^.Assign, R must be valid !! }
+                     if ((p^.procdefinition^.options and poconstructor) <> 0) or
+                        ((p^.methodpointer^.treetype=loadn) and
+                        ((pobjectdef(p^.methodpointer^.resulttype)^.options and oo_hasvirtual) = 0)) then
+                       must_be_valid:=false
+                     else
+                       must_be_valid:=true;
+                     firstpass(p^.methodpointer);
+                     p^.registersfpu:=max(p^.methodpointer^.registersfpu,p^.registersfpu);
+                     p^.registers32:=max(p^.methodpointer^.registers32,p^.registers32);
+{$ifdef SUPPORT_MMX}
+                     p^.registersmmx:=max(p^.methodpointer^.registersmmx,p^.registersmmx);
+{$endif SUPPORT_MMX}
+                  end;
+              end;
+           end;
+
+         { determine the registers of the procedure variable }
+         if assigned(p^.right) then
+           begin
+              p^.registersfpu:=max(p^.right^.registersfpu,p^.registersfpu);
+              p^.registers32:=max(p^.right^.registers32,p^.registers32);
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=max(p^.right^.registersmmx,p^.registersmmx);
+{$endif SUPPORT_MMX}
+           end;
+         { determine the registers of the procedure }
+         if assigned(p^.left) then
+           begin
+              p^.registersfpu:=max(p^.left^.registersfpu,p^.registersfpu);
+              p^.registers32:=max(p^.left^.registers32,p^.registers32);
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=max(p^.left^.registersmmx,p^.registersmmx);
+{$endif SUPPORT_MMX}
+           end;
+         if assigned(procs) then
+           dispose(procs);
+         must_be_valid:=store_valid;
+      end;
+
+    procedure firstfuncret(var p : ptree);
+
+          begin
+{$ifdef TEST_FUNCRET}
+             p^.resulttype:=p^.retdef;
+             p^.location.loc:=LOC_REFERENCE;
+             if ret_in_param(p^.retdef) or
+                (@procinfo<>pprocinfo(p^.funcretprocinfo)) then
+               p^.registers32:=1;
+{$ifdef GDB}
+         if must_be_valid and not pprocinfo(p^.funcretprocinfo)^.funcret_is_valid then
+           note(uninitialized_function_return);
+         if count_ref then pprocinfo(p^.funcretprocinfo)^.funcret_is_valid:=true;
+{$endif * GDB *}
+{$else TEST_FUNCRET}
+         p^.resulttype:=procinfo.retdef;
+         p^.location.loc:=LOC_REFERENCE;
+         if ret_in_param(procinfo.retdef) then
+           p^.registers32:=1;
+{$ifdef GDB}
+         if must_be_valid and not procinfo.funcret_is_valid then
+           Message(sym_w_function_result_not_set);
+         if count_ref then procinfo.funcret_is_valid:=true;
+{$endif * GDB *}
+{$endif TEST_FUNCRET}
+          end;
+
+
+    { intern inline suborutines }
+    procedure firstinline(var p : ptree);
+
+      var
+         hp,hpp : ptree;
+         isreal,store_valid,file_is_typed : boolean;
+         convtyp : tconverttype;
+
+      procedure do_lowhigh(adef : pdef);
+
+        var
+           v : longint;
+           enum : penumsym;
+
+        begin
+           case Adef^.deftype of
+             orddef:
+               begin
+                  if p^.inlinenumber=in_low_x then
+                    v:=porddef(Adef)^.von
+                  else
+                    v:=porddef(Adef)^.bis;
+                  hp:=genordinalconstnode(v,adef);
+                  disposetree(p);
+                  p:=hp;
+               end;
+             enumdef:
+               begin
+                  enum:=Penumdef(Adef)^.first;
+                  if p^.inlinenumber=in_high_x then
+                    while enum^.next<>nil do
+                      enum:=enum^.next;
+                  hp:=genenumnode(enum);
+                  disposetree(p);
+                  p:=hp;
+               end
+           end;
+        end;
+
+      begin
+         { if we handle writeln; p^.left contains no valid address }
+         if assigned(p^.left) then
+           begin
+              p^.registers32:=p^.left^.registers32;
+              p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+              set_location(p^.location,p^.left^.location);
+           end;
+           store_valid:=must_be_valid;
+           if not (p^.inlinenumber in [in_read_x,in_readln_x,in_sizeof_x,
+                                       in_typeof_x,in_ord_x,
+                                       in_reset_typedfile,in_rewrite_typedfile]) then
+             must_be_valid:=true
+             else must_be_valid:=false;
+           case p^.inlinenumber of
+             in_lo_word,in_hi_word:
+               begin
+                  if p^.registers32<1 then
+                    p^.registers32:=1;
+                  p^.resulttype:=u8bitdef;
+                  p^.location.loc:=LOC_REGISTER;
+               end;
+             in_lo_long,in_hi_long:
+               begin
+                  if p^.registers32<1 then
+                    p^.registers32:=1;
+                  p^.resulttype:=u16bitdef;
+                  p^.location.loc:=LOC_REGISTER;
+               end;
+             in_sizeof_x:
+               begin
+                  if p^.registers32<1 then
+                    p^.registers32:=1;
+                  p^.resulttype:=s32bitdef;
+                  p^.location.loc:=LOC_REGISTER;
+               end;
+             in_typeof_x:
+               begin
+                  if p^.registers32<1 then
+                    p^.registers32:=1;
+                  p^.location.loc:=LOC_REGISTER;
+                  p^.resulttype:=voidpointerdef;
+               end;
+             in_ord_x:
+               begin
+                  if (p^.left^.treetype=ordconstn) then
+                    begin
+                       hp:=genordinalconstnode(p^.left^.value,s32bitdef);
+                       disposetree(p);
+                       p:=hp;
+                       firstpass(p);
+                    end
+                  else
+                    begin
+                       if (p^.left^.resulttype^.deftype=orddef) then
+                         if (porddef(p^.left^.resulttype)^.typ=uchar) or
+                            (porddef(p^.left^.resulttype)^.typ=bool8bit) then
+                           begin
+                              if porddef(p^.left^.resulttype)^.typ=bool8bit then
+                                begin
+                                   hp:=gentypeconvnode(p^.left,u8bitdef);
+                                   putnode(p);
+                                   p:=hp;
+                                   p^.convtyp:=tc_bool_2_u8bit;
+                                   p^.explizit:=true;
+                                   firstpass(p);
+                                end
+                              else
+                                begin
+                                   hp:=gentypeconvnode(p^.left,u8bitdef);
+                                   putnode(p);
+                                   p:=hp;
+                                   p^.explizit:=true;
+                                   firstpass(p);
+                                end;
+                           end
+                         { can this happen ? }
+                         else if (porddef(p^.left^.resulttype)^.typ=uvoid) then
+                           Message(sym_e_type_mismatch)
+                         else
+                           { all other orddef need no transformation }
+                           begin
+                              hp:=p^.left;
+                              putnode(p);
+                              p:=hp;
+                           end
+                       else if (p^.left^.resulttype^.deftype=enumdef) then
+                         begin
+                            hp:=gentypeconvnode(p^.left,s32bitdef);
+                            putnode(p);
+                            p:=hp;
+                            p^.explizit:=true;
+                            firstpass(p);
+                         end
+                       else
+                         begin
+                            { can anything else be ord() ?}
+                            Message(sym_e_type_mismatch);
+                         end;
+                    end;
+               end;
+             in_chr_byte:
+               begin
+                  hp:=gentypeconvnode(p^.left,cchardef);
+                  putnode(p);
+                  p:=hp;
+                  p^.explizit:=true;
+                  firstpass(p);
+               end;
+             in_length_string:
+               begin
+                  p^.resulttype:=u8bitdef;
+                  { String nach Stringkonvertierungen brauchen wir hier nicht }
+                  if (p^.left^.treetype=typeconvn) and
+                     (p^.left^.left^.resulttype^.deftype=stringdef) then
+                    begin
+                       hp:=p^.left^.left;
+                       putnode(p^.left);
+                       p^.left:=hp;
+                    end;
+
+                  { evalutes length of constant strings direct }
+                  if (p^.left^.treetype=stringconstn) then
+                    begin
+                       hp:=genordinalconstnode(length(p^.left^.values^),s32bitdef);
+                       disposetree(p);
+                       firstpass(hp);
+                       p:=hp;
+                    end;
+
+               end;
+             in_assigned_x:
+               begin
+                  p^.resulttype:=booldef;
+                  p^.location.loc:=LOC_FLAGS;
+               end;
+             in_pred_x,
+             in_succ_x:
+               begin
+                  p^.resulttype:=p^.left^.resulttype;
+                  p^.location.loc:=LOC_REGISTER;
+                  if not is_ordinal(p^.resulttype) then
+                     Message(sym_e_type_mismatch)
+                  else
+                    begin
+                  if (p^.resulttype^.deftype=enumdef) and
+                     (penumdef(p^.resulttype)^.has_jumps) then
+                    begin
+                      Message(parser_e_succ_and_pred_enums_with_assign_not_possible);
+                      exit;
+                    end;
+                       if p^.left^.treetype=ordconstn then
+                         begin
+                            if p^.inlinenumber=in_pred_x then
+                              hp:=genordinalconstnode(p^.left^.value+1,
+                                p^.left^.resulttype)
+                            else
+                              hp:=genordinalconstnode(p^.left^.value-1,
+                                p^.left^.resulttype);
+                            disposetree(p);
+                            firstpass(hp);
+                            p:=hp;
+                         end;
+                    end;
+               end;
+             in_dec_dword,
+             in_dec_word,
+             in_dec_byte,
+             in_inc_dword,
+             in_inc_word,
+             in_inc_byte :
+               begin
+                  p^.resulttype:=voiddef;
+                  if p^.left^.location.loc<>LOC_REFERENCE then
+                    Message(cg_e_illegal_expression);
+               end;
+            in_inc_x,
+            in_dec_x:
+              begin
+                 p^.resulttype:=voiddef;
+                 if assigned(p^.left) then
+                   begin
+                      firstcallparan(p^.left,nil);
+                      { first param must be var }
+                      if p^.left^.left^.location.loc<>LOC_REFERENCE then
+                        Message(cg_e_illegal_expression);
+                      { check type }
+                      if (p^.left^.resulttype^.deftype=pointerdef) or
+                        (p^.left^.resulttype^.deftype=enumdef) or
+                        ( (p^.left^.resulttype^.deftype=orddef) and
+                          (porddef(p^.left^.resulttype)^.typ in [u8bit,s8bit,u16bit,s16bit,u32bit,s32bit])
+                        ) then
+                        begin
+                           { two paras ? }
+                           if assigned(p^.left^.right) then
+                             begin
+                                { insert a type conversion         }
+                                { the second param is always longint }
+                                p^.left^.right^.left:=gentypeconvnode(
+                                  p^.left^.right^.left,
+                                  s32bitdef);
+                                { check the type conversion }
+                                firstpass(p^.left^.right^.left);
+                                if assigned(p^.left^.right^.right) then
+                                  Message(cg_e_illegal_expression);
+                             end;
+                        end
+                      else
+                        Message(sym_e_type_mismatch);
+                   end
+                 else
+                   Message(sym_e_type_mismatch);
+              end;
+             in_read_x,
+             in_readln_x,
+             in_write_x,
+             in_writeln_x :
+               begin
+                  { needs a call }
+                  procinfo.flags:=procinfo.flags or pi_do_call;
+                  p^.resulttype:=voiddef;
+                  { we must know if it is a typed file or not }
+                  { but we must first do the firstpass for it }
+                  file_is_typed:=false;
+                  if assigned(p^.left) then
+                    begin
+                       firstcallparan(p^.left,nil);
+                       { now we can check }
+                       hp:=p^.left;
+                       while assigned(hp^.right) do
+                         hp:=hp^.right;
+                       { if resulttype is not assigned, then automatically }
+                       { file is not typed.                                }
+                       if assigned(hp) and assigned(hp^.resulttype) then
+                         Begin
+                           if (hp^.resulttype^.deftype=filedef) and
+                            (pfiledef(hp^.resulttype)^.filetype=ft_typed) then
+                           begin
+                              file_is_typed:=true;
+                              { test the type here
+                                so we can use a trick in cgi386 (PM) }
+                              hpp:=p^.left;
+                              while (hpp<>hp) do
+                                begin
+                                   { should we allow type conversion ? (PM)
+                                   if not isconvertable(hpp^.resulttype,
+                                     pfiledef(hp^.resulttype)^.typed_as,convtyp,hpp^.treetype) then
+                                     Message(sym_e_type_mismatch);
+                                   if not(is_equal(hpp^.resulttype,pfiledef(hp^.resulttype)^.typed_as)) then
+                                     begin
+                                        hpp^.left:=gentypeconvnode(hpp^.left,pfiledef(hp^.resulttype)^.typed_as);
+                                     end; }
+                                   if not is_equal(hpp^.resulttype,pfiledef(hp^.resulttype)^.typed_as) then
+                                     Message(sym_e_type_mismatch);
+                                   hpp:=hpp^.right;
+                                end;
+                              { once again for typeconversions }
+                              firstcallparan(p^.left,nil);
+                           end;
+                         end; { endif assigned(hp) }
+                       { insert type conversions for write(ln) }
+                       if (not file_is_typed) and
+                          ((p^.inlinenumber=in_write_x) or (p^.inlinenumber=in_writeln_x)) then
+                         begin
+                            hp:=p^.left;
+                            while assigned(hp) do
+                              begin
+                                if assigned(hp^.left^.resulttype) then
+                                  begin
+
+                                   if hp^.left^.resulttype^.deftype=floatdef then
+                                     begin
+                                        isreal:=true;
+                                     end
+                                   else if hp^.left^.resulttype^.deftype=orddef then
+                                     case porddef(hp^.left^.resulttype)^.typ of
+                                       u8bit,s8bit,
+                                       u16bit,s16bit :
+                                         hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
+                                       end
+                                   { but we convert only if the first index<>0, because in this case }
+                                   { we have a ASCIIZ string                                         }
+                                   else if (hp^.left^.resulttype^.deftype=arraydef) and
+                                           (parraydef(hp^.left^.resulttype)^.lowrange<>0) and
+                                           (parraydef(hp^.left^.resulttype)^.definition^.deftype=orddef) and
+                                           (porddef(parraydef(hp^.left^.resulttype)^.definition)^.typ=uchar) then
+                                     hp^.left:=gentypeconvnode(hp^.left,cstringdef);
+                                  end;
+                                 hp:=hp^.right;
+                              end;
+                         end;
+                       { nochmals alle Parameter bearbeiten }
+                       firstcallparan(p^.left,nil);
+                    end;
+               end;
+            in_settextbuf_file_x :
+              begin
+                 { warning here p^.left is the callparannode
+                   not the argument directly }
+                 { p^.left^.left is text var }
+                 { p^.left^.right^.left is the buffer var }
+                 { firstcallparan(p^.left,nil);
+                   already done in firstcalln }
+                 { now we know the type of buffer }
+                 getsymonlyin(systemunit,'SETTEXTBUF');
+                 hp:=gencallnode(pprocsym(srsym),systemunit);
+                 hp^.left:=gencallparanode(
+                   genordinalconstnode(p^.left^.left^.resulttype^.size,s32bitdef),p^.left);
+                 putnode(p);
+                 p:=hp;
+                 firstpass(p);
+              end;
+             { the firstpass of the arg has been done in firstcalln ? }
+             in_reset_typedfile,in_rewrite_typedfile :
+               begin
+                  procinfo.flags:=procinfo.flags or pi_do_call;
+                  { to be sure the right definition is loaded }
+                  p^.left^.resulttype:=nil;
+                  firstload(p^.left);
+                  p^.resulttype:=voiddef;
+               end;
+             in_str_x_string :
+               begin
+                  procinfo.flags:=procinfo.flags or pi_do_call;
+                  p^.resulttype:=voiddef;
+                  if assigned(p^.left) then
+                    begin
+                       hp:=p^.left^.right;
+                       { first pass just the string for first local use }
+                       must_be_valid:=false;
+                       count_ref:=true;
+                       p^.left^.right:=nil;
+                       firstcallparan(p^.left,nil);
+                       p^.left^.right:=hp;
+                       must_be_valid:=true;
+                       firstcallparan(p^.left,nil);
+                       hp:=p^.left;
+                       isreal:=false;
+                       { valid string ? }
+                       if not assigned(hp) or
+                          (hp^.left^.resulttype^.deftype<>stringdef) or
+                          (hp^.right=nil) or
+                          (hp^.left^.location.loc<>LOC_REFERENCE) then
+                         Message(cg_e_illegal_expression);
+                       { !!!! check length of string }
+
+                       while assigned(hp^.right) do hp:=hp^.right;
+
+                       { check and convert the first param }
+                       if hp^.is_colon_para then
+                         Message(cg_e_illegal_expression)
+                       else if hp^.resulttype^.deftype=orddef then
+                         case porddef(hp^.left^.resulttype)^.typ of
+                           u8bit,s8bit,
+                           u16bit,s16bit :
+                             hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
+                         end
+                       else if hp^.resulttype^.deftype=floatdef then
+                         begin
+                            isreal:=true;
+                         end
+                       else Message(cg_e_illegal_expression);
+
+                       { some format options ? }
+                       hp:=p^.left^.right;
+                       if assigned(hp) and hp^.is_colon_para then
+                         begin
+                            hp^.left:=gentypeconvnode(hp^.left,s32bitdef);
+                            hp:=hp^.right;
+                         end;
+                       if assigned(hp) and hp^.is_colon_para then
+                         begin
+                            if isreal then
+                              hp^.left:=gentypeconvnode(hp^.left,s32bitdef)
+                            else
+                              Message(parser_e_illegal_colon_qualifier);
+                            hp:=hp^.right;
+                         end;
+
+                       { for first local use }
+                       must_be_valid:=false;
+                       count_ref:=true;
+                       if assigned(hp) then
+                         firstcallparan(hp,nil);
+                    end
+                  else
+                    Message(parser_e_illegal_parameter_list);
+                  { check params once more }
+                  if codegenerror then
+                    exit;
+                  must_be_valid:=true;
+                  firstcallparan(p^.left,nil);
+               end;
+             in_low_x,in_high_x:
+               begin
+                  if p^.left^.treetype in [typen,loadn] then
+                    begin
+                       case p^.left^.resulttype^.deftype of
+                  orddef,enumdef:
+                begin
+                               do_lowhigh(p^.left^.resulttype);
+                               firstpass(p);
+                            end;
+              setdef:
+                        begin
+                               do_lowhigh(Psetdef(p^.left^.resulttype)^.setof);
+                               firstpass(p);
+                            end;
+                         arraydef:
+                begin
+                              if is_open_array(p^.left^.resulttype) then
+                                begin
+                                   if p^.inlinenumber=in_low_x then
+                                     begin
+                                        hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.lowrange,s32bitdef);
+                                        disposetree(p);
+                                        p:=hp;
+                                        firstpass(p);
+                                     end
+                                   else
+                                     begin
+                                        p^.resulttype:=s32bitdef;
+                                        p^.registers32:=max(1,
+                                          p^.registers32);
+                                        p^.location.loc:=LOC_REGISTER;
+                                     end;
+                                end
+                              else
+                                begin
+                                   if p^.inlinenumber=in_low_x then
+                                     hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.lowrange,s32bitdef)
+                                   else
+                                     hp:=genordinalconstnode(Parraydef(p^.left^.resulttype)^.highrange,s32bitdef);
+                                   disposetree(p);
+                                   p:=hp;
+                                   firstpass(p);
+                                end;
+                           end;
+                         stringdef:
+                           begin
+                              if p^.inlinenumber=in_low_x then
+                                hp:=genordinalconstnode(0,u8bitdef)
+                              else
+                                hp:=genordinalconstnode(Pstringdef(p^.left^.resulttype)^.len,u8bitdef);
+                              disposetree(p);
+                              p:=hp;
+                              firstpass(p);
+                           end;
+                         else
+                           Message(sym_e_type_mismatch);
+                         end;
+                    end
+                  else
+                    Message(parser_e_varid_or_typeid_expected);
+               end
+                 else internalerror(8);
+             end;
+           must_be_valid:=store_valid;
+       end;
+
+    procedure firstsubscriptn(var p : ptree);
+
+      begin
+         firstpass(p^.left);
+
+         if codegenerror then
+           exit;
+
+         p^.resulttype:=p^.vs^.definition;
+         if count_ref and not must_be_valid then
+           if (p^.vs^.properties and sp_protected)<>0 then
+             Message(parser_e_cant_write_protected_member);
+         p^.registers32:=p^.left^.registers32;
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+         { classes must be dereferenced implicit }
+         if (p^.left^.resulttype^.deftype=objectdef) and
+           pobjectdef(p^.left^.resulttype)^.isclass then
+           begin
+              if p^.registers32=0 then
+                p^.registers32:=1;
+              p^.location.loc:=LOC_REFERENCE;
+           end
+         else
+           begin
+              if (p^.left^.location.loc<>LOC_MEM) and
+                (p^.left^.location.loc<>LOC_REFERENCE) then
+                Message(cg_e_illegal_expression);
+              set_location(p^.location,p^.left^.location);
+           end;
+      end;
+
+    procedure firstselfn(var p : ptree);
+
+      begin
+         if (p^.resulttype^.deftype=classrefdef) or
+           ((p^.resulttype^.deftype=objectdef)
+             and pobjectdef(p^.resulttype)^.isclass
+           ) then
+           p^.location.loc:=LOC_REGISTER
+         else
+           p^.location.loc:=LOC_REFERENCE;
+      end;
+
+    procedure firsttypen(var p : ptree);
+
+      begin
+{       DM: Why not allowed? For example: low(word) results in a type
+        id of word.
+        error(typeid_here_not_allowed);}
+      end;
+
+    procedure firsthnewn(var p : ptree);
+
+      begin
+      end;
+
+    procedure firsthdisposen(var p : ptree);
+
+      begin
+         firstpass(p^.left);
+
+         if codegenerror then
+           exit;
+
+         p^.registers32:=p^.left^.registers32;
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+         if p^.registers32<1 then
+           p^.registers32:=1;
+         {
+         if p^.left^.location.loc<>LOC_REFERENCE then
+           Message(cg_e_illegal_expression);
+         }
+         p^.location.loc:=LOC_REFERENCE;
+         p^.resulttype:=ppointerdef(p^.left^.resulttype)^.definition;
+      end;
+
+    procedure firstnewn(var p : ptree);
+
+      begin
+         { Standardeinleitung }
+         firstpass(p^.left);
+
+         if codegenerror then
+           exit;
+         p^.registers32:=p^.left^.registers32;
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+         { result type is already set }
+         procinfo.flags:=procinfo.flags or pi_do_call;
+         p^.location.loc:=LOC_REGISTER;
+      end;
+
+    procedure firstsimplenewdispose(var p : ptree);
+
+      begin
+         { this cannot be in a register !! }
+         make_not_regable(p^.left);
+
+         firstpass(p^.left);
+
+         { check the type }
+         if (p^.left^.resulttype=nil) or (p^.left^.resulttype^.deftype<>pointerdef) then
+           Message(parser_e_pointer_type_expected);
+
+         if (p^.left^.location.loc<>LOC_REFERENCE) {and
+            (p^.left^.location.loc<>LOC_CREGISTER)} then
+           Message(cg_e_illegal_expression);
+
+         p^.registers32:=p^.left^.registers32;
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=voiddef;
+         procinfo.flags:=procinfo.flags or pi_do_call;
+      end;
+
+    procedure firstsetcons(var p : ptree);
+
+      var
+         hp : ptree;
+
+      begin
+         p^.location.loc:=LOC_MEM;
+         hp:=p^.left;
+         { is done by getnode*
+         p^.registers32:=0;
+         p^.registersfpu:=0;
+         }
+         while assigned(hp) do
+           begin
+              firstpass(hp^.left);
+
+              if codegenerror then
+                exit;
+
+              p^.registers32:=max(p^.registers32,hp^.left^.registers32);
+              p^.registersfpu:=max(p^.registersfpu,hp^.left^.registersfpu);;
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=max(p^.registersmmx,hp^.left^.registersmmx);
+{$endif SUPPORT_MMX}
+              hp:=hp^.right;
+           end;
+         { result type is already set }
+      end;
+
+    procedure firstin(var p : ptree);
+
+      begin
+         p^.location.loc:=LOC_FLAGS;
+         p^.resulttype:=booldef;
+
+         firstpass(p^.right);
+         if codegenerror then
+           exit;
+
+         if p^.right^.resulttype^.deftype<>setdef then
+          Message(sym_e_set_expected);
+
+         firstpass(p^.left);
+         if codegenerror then
+           exit;
+
+         p^.left:=gentypeconvnode(p^.left,psetdef(p^.right^.resulttype)^.setof);
+
+         firstpass(p^.left);
+         if codegenerror then
+           exit;
+
+         p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
+         p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
+         { this is not allways true due to optimization }
+         { but if we don't set this we get problems with optimizing self code }
+         if psetdef(p^.right^.resulttype)^.settype<>smallset then
+           procinfo.flags:=procinfo.flags or pi_do_call;
+      end;
+
+    { !!!!!!!!!!!! unused }
+    procedure firstexpr(var p : ptree);
+
+      begin
+         firstpass(p^.left);
+         if codegenerror then
+           exit;
+         p^.registers32:=p^.left^.registers32;
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+         if (cs_extsyntax in aktswitches) and (p^.left^.resulttype<>pdef(voiddef)) then
+           Message(cg_e_illegal_expression);
+      end;
+
+    procedure firstblock(var p : ptree);
+
+      var
+         hp : ptree;
+         count : longint;
+
+      begin
+         count:=0;
+         hp:=p^.left;
+         while assigned(hp) do
+           begin
+              if cs_maxoptimieren in aktswitches then
+                begin
+                   { Codeumstellungen }
+
+                   { Funktionsresultate an exit anh„ngen }
+                   { this is wrong for string or other complex
+                     result types !!! }
+                   if ret_in_acc(procinfo.retdef) and
+                      assigned(hp^.left) and
+                      (hp^.left^.right^.treetype=exitn) and
+                      (hp^.right^.treetype=assignn) and
+                      (hp^.right^.left^.treetype=funcretn) then
+                      begin
+                         if assigned(hp^.left^.right^.left) then
+                           Message(cg_n_inefficient_code)
+                         else
+                           begin
+                              hp^.left^.right^.left:=getcopy(hp^.right^.right);
+                              disposetree(hp^.right);
+                              hp^.right:=nil;
+                           end;
+                      end
+                   { warning if unreachable code occurs and elimate this }
+                                   else if (hp^.right^.treetype in
+                                        [exitn,breakn,continuen,goton]) and
+                                        assigned(hp^.left) and
+                                        (hp^.left^.treetype<>labeln) then
+                                                 begin
+                                                        { use correct line number }
+                                                        current_module^.current_inputfile:=hp^.left^.inputfile;
+                                                        current_module^.current_inputfile^.line_no:=hp^.left^.line;
+
+                                                        disposetree(hp^.left);
+                            hp^.left:=nil;
+                            Message(cg_w_unreachable_code);
+
+                            { old lines }
+                            current_module^.current_inputfile:=hp^.right^.inputfile;
+                            current_module^.current_inputfile^.line_no:=hp^.right^.line;
+                         end;
+                end;
+              if assigned(hp^.right) then
+                begin
+                   cleartempgen;
+                   firstpass(hp^.right);
+                   if codegenerror then
+                     exit;
+
+                   hp^.registers32:=hp^.right^.registers32;
+                   hp^.registersfpu:=hp^.right^.registersfpu;
+{$ifdef SUPPORT_MMX}
+                   hp^.registersmmx:=hp^.right^.registersmmx;
+{$endif SUPPORT_MMX}
+                end
+              else
+                hp^.registers32:=0;
+
+              if hp^.registers32>p^.registers32 then
+                p^.registers32:=hp^.registers32;
+              if hp^.registersfpu>p^.registersfpu then
+                p^.registersfpu:=hp^.registersfpu;
+{$ifdef SUPPORT_MMX}
+              if hp^.registersmmx>p^.registersmmx then
+                p^.registersmmx:=hp^.registersmmx;
+{$endif}
+              inc(count);
+              hp:=hp^.left;
+           end;
+         { p^.registers32:=round(p^.registers32/count); }
+      end;
+
+    procedure first_while_repeat(var p : ptree);
+
+      var
+         old_t_times : longint;
+
+      begin
+         old_t_times:=t_times;
+
+                 { Registergewichtung bestimmen }
+         if not(cs_littlesize in aktswitches ) then
+           t_times:=t_times*8;
+
+         cleartempgen;
+         must_be_valid:=true;
+         firstpass(p^.left);
+         if codegenerror then
+           exit;
+         if not((p^.left^.resulttype^.deftype=orddef) and
+            (porddef(p^.left^.resulttype)^.typ=bool8bit)) then
+            begin
+               Message(sym_e_type_mismatch);
+               exit;
+            end;
+
+         p^.registers32:=p^.left^.registers32;
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+
+         { loop instruction }
+         if assigned(p^.right) then
+           begin
+              cleartempgen;
+              firstpass(p^.right);
+              if codegenerror then
+                exit;
+
+              if p^.registers32<p^.right^.registers32 then
+                p^.registers32:=p^.right^.registers32;
+              if p^.registersfpu<p^.right^.registersfpu then
+                p^.registersfpu:=p^.right^.registersfpu;
+{$ifdef SUPPORT_MMX}
+              if p^.registersmmx<p^.right^.registersmmx then
+                p^.registersmmx:=p^.right^.registersmmx;
+{$endif SUPPORT_MMX}
+           end;
+
+         t_times:=old_t_times;
+      end;
+
+    procedure firstif(var p : ptree);
+
+      var
+         old_t_times : longint;
+         hp : ptree;
+
+      begin
+         old_t_times:=t_times;
+
+         cleartempgen;
+         must_be_valid:=true;
+         firstpass(p^.left);
+         if codegenerror then
+           exit;
+         if not((p^.left^.resulttype^.deftype=orddef) and
+            (porddef(p^.left^.resulttype)^.typ=bool8bit)) then
+            begin
+               Message(sym_e_type_mismatch);
+               exit;
+            end;
+
+         p^.registers32:=p^.left^.registers32;
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+
+         { determines registers weigths }
+         if not(cs_littlesize in aktswitches ) then
+           t_times:=t_times div 2;
+         if t_times=0 then
+           t_times:=1;
+
+         { if path }
+         if assigned(p^.right) then
+           begin
+              cleartempgen;
+              firstpass(p^.right);
+              if codegenerror then
+                exit;
+
+              if p^.registers32<p^.right^.registers32 then
+                p^.registers32:=p^.right^.registers32;
+              if p^.registersfpu<p^.right^.registersfpu then
+                p^.registersfpu:=p^.right^.registersfpu;
+{$ifdef SUPPORT_MMX}
+              if p^.registersmmx<p^.right^.registersmmx then
+                p^.registersmmx:=p^.right^.registersmmx;
+{$endif SUPPORT_MMX}
+           end;
+
+         { else path }
+         if assigned(p^.t1) then
+           begin
+              cleartempgen;
+              firstpass(p^.t1);
+              if codegenerror then
+                exit;
+
+              if p^.registers32<p^.t1^.registers32 then
+                p^.registers32:=p^.t1^.registers32;
+              if p^.registersfpu<p^.t1^.registersfpu then
+                p^.registersfpu:=p^.t1^.registersfpu;
+{$ifdef SUPPORT_MMX}
+              if p^.registersmmx<p^.t1^.registersmmx then
+                p^.registersmmx:=p^.t1^.registersmmx;
+{$endif SUPPORT_MMX}
+           end;
+         if p^.left^.treetype=ordconstn then
+           begin
+              { optimize }
+              if p^.left^.value=1 then
+                begin
+                   disposetree(p^.left);
+                   hp:=p^.right;
+                   disposetree(p^.t1);
+                   { we cannot set p to nil !!! }
+                   if assigned(hp) then
+                     begin
+                        putnode(p);
+                        p:=hp;
+                     end
+                   else
+                     begin
+                        p^.left:=nil;
+                        p^.t1:=nil;
+                        p^.treetype:=nothingn;
+                     end;
+                end
+              else
+                begin
+                   disposetree(p^.left);
+                   hp:=p^.t1;
+                   disposetree(p^.right);
+                   { we cannot set p to nil !!! }
+                   if assigned(hp) then
+                     begin
+                        putnode(p);
+                        p:=hp;
+                     end
+                   else
+                     begin
+                        p^.left:=nil;
+                        p^.right:=nil;
+                        p^.treetype:=nothingn;
+                     end;
+                end;
+           end;
+
+         t_times:=old_t_times;
+      end;
+
+    procedure firstexitn(var p : ptree);
+
+      begin
+         if assigned(p^.left) then
+           begin
+              firstpass(p^.left);
+              p^.registers32:=p^.left^.registers32;
+              p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+           end;
+      end;
+
+    procedure firstfor(var p : ptree);
+
+      var
+         old_t_times : longint;
+
+      begin
+         { Registergewichtung bestimmen
+           (nicht genau), }
+         old_t_times:=t_times;
+         if not(cs_littlesize in aktswitches ) then
+           t_times:=t_times*8;
+
+         cleartempgen;
+         if p^.t1<>nil then
+           firstpass(p^.t1);
+
+         p^.registers32:=p^.t1^.registers32;
+         p^.registersfpu:=p^.t1^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+
+         if p^.left^.treetype<>assignn then
+           Message(cg_e_illegal_expression);
+
+         { Laufvariable retten }
+         p^.t2:=getcopy(p^.left^.left);
+
+         { Check count var }
+         if (p^.t2^.treetype<>loadn) then
+          Message(cg_e_illegal_count_var);
+
+         if (not(is_ordinal(p^.t2^.resulttype))) then
+          Message(parser_e_ordinal_expected);
+
+         cleartempgen;
+         must_be_valid:=false;
+         firstpass(p^.left);
+         must_be_valid:=true;
+         if p^.left^.registers32>p^.registers32 then
+           p^.registers32:=p^.left^.registers32;
+         if p^.left^.registersfpu>p^.registersfpu then
+           p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         if p^.left^.registersmmx>p^.registersmmx then
+           p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+         cleartempgen;
+         firstpass(p^.t2);
+         if p^.t2^.registers32>p^.registers32 then
+           p^.registers32:=p^.t2^.registers32;
+         if p^.t2^.registersfpu>p^.registersfpu then
+           p^.registersfpu:=p^.t2^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         if p^.t2^.registersmmx>p^.registersmmx then
+           p^.registersmmx:=p^.t2^.registersmmx;
+{$endif SUPPORT_MMX}
+
+         cleartempgen;
+         firstpass(p^.right);
+         if p^.right^.treetype<>ordconstn then
+           begin
+              p^.right:=gentypeconvnode(p^.right,p^.t2^.resulttype);
+              cleartempgen;
+              firstpass(p^.right);
+           end;
+
+         if p^.right^.registers32>p^.registers32 then
+           p^.registers32:=p^.right^.registers32;
+         if p^.right^.registersfpu>p^.registersfpu then
+           p^.registersfpu:=p^.right^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         if p^.right^.registersmmx>p^.registersmmx then
+           p^.registersmmx:=p^.right^.registersmmx;
+{$endif SUPPORT_MMX}
+         t_times:=old_t_times;
+      end;
+
+    procedure firstasm(var p : ptree);
+
+      begin
+         { it's a f... to determine the used registers }
+         { should be done by getnode
+           I think also, that all values should be set to their maximum (FK)
+         p^.registers32:=0;
+         p^.registersfpu:=0;
+         p^.registersmmx:=0;
+         }
+         procinfo.flags:=procinfo.flags or pi_uses_asm;
+      end;
+
+    procedure firstgoto(var p : ptree);
+
+      begin
+         {
+         p^.registers32:=0;
+         p^.registersfpu:=0;
+         }
+         p^.resulttype:=voiddef;
+      end;
+
+    procedure firstlabel(var p : ptree);
+
+      begin
+         cleartempgen;
+         firstpass(p^.left);
+         p^.registers32:=p^.left^.registers32;
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=voiddef;
+      end;
+
+    procedure firstcase(var p : ptree);
+
+      var
+         old_t_times : longint;
+         hp : ptree;
+
+      begin
+         { evalutes the case expression }
+         cleartempgen;
+         must_be_valid:=true;
+         firstpass(p^.left);
+         if codegenerror then
+           exit;
+         p^.registers32:=p^.left^.registers32;
+         p^.registersfpu:=p^.left^.registersfpu;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+
+         { walk through all instructions }
+
+         {   estimates the repeat of each instruction }
+         old_t_times:=t_times;
+         if not(cs_littlesize in aktswitches ) then
+           begin
+              t_times:=t_times div case_count_labels(p^.nodes);
+              if t_times<1 then
+                t_times:=1;
+           end;
+         {   first case }
+         hp:=p^.right;
+         while assigned(hp) do
+           begin
+              cleartempgen;
+              firstpass(hp^.right);
+
+              { searchs max registers }
+              if hp^.right^.registers32>p^.registers32 then
+                p^.registers32:=hp^.right^.registers32;
+              if hp^.right^.registersfpu>p^.registersfpu then
+                p^.registersfpu:=hp^.right^.registersfpu;
+{$ifdef SUPPORT_MMX}
+              if hp^.right^.registersmmx>p^.registersmmx then
+                p^.registersmmx:=hp^.right^.registersmmx;
+{$endif SUPPORT_MMX}
+
+              hp:=hp^.left;
+           end;
+
+         { may be handle else tree }
+         if assigned(p^.elseblock) then
+           begin
+              cleartempgen;
+              firstpass(p^.elseblock);
+              if codegenerror then
+                exit;
+              if p^.registers32<p^.elseblock^.registers32 then
+                p^.registers32:=p^.elseblock^.registers32;
+              if p^.registersfpu<p^.elseblock^.registersfpu then
+                p^.registersfpu:=p^.elseblock^.registersfpu;
+{$ifdef SUPPORT_MMX}
+              if p^.registersmmx<p^.elseblock^.registersmmx then
+                p^.registersmmx:=p^.elseblock^.registersmmx;
+{$endif SUPPORT_MMX}
+           end;
+         t_times:=old_t_times;
+
+         { there is one register required for the case expression }
+         if p^.registers32<1 then p^.registers32:=1;
+      end;
+
+    procedure firsttryexcept(var p : ptree);
+
+      begin
+      end;
+
+    procedure firsttryfinally(var p : ptree);
+
+      begin
+      end;
+
+    procedure firstis(var p : ptree);
+
+      begin
+         firstpass(p^.left);
+         firstpass(p^.right);
+
+         if (p^.right^.resulttype^.deftype<>classrefdef) then
+           Message(sym_e_type_mismatch);
+         if codegenerror then
+           exit;
+
+         p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
+         p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
+
+         { left must be a class }
+         if (p^.left^.resulttype^.deftype<>objectdef) or
+           not(pobjectdef(p^.left^.resulttype)^.isclass) then
+           Message(sym_e_type_mismatch);
+
+         { the operands must be related }
+         if (not(pobjectdef(p^.left^.resulttype)^.isrelated(
+           pobjectdef(pclassrefdef(p^.right^.resulttype)^.definition)))) and
+           (not(pobjectdef(pclassrefdef(p^.right^.resulttype)^.definition)^.isrelated(
+           pobjectdef(p^.left^.resulttype)))) then
+           Message(sym_e_type_mismatch);
+
+         p^.location.loc:=LOC_FLAGS;
+         p^.resulttype:=booldef;
+      end;
+
+    procedure firstas(var p : ptree);
+
+      begin
+         firstpass(p^.right);
+         firstpass(p^.left);
+         if (p^.right^.resulttype^.deftype<>classrefdef) then
+           Message(sym_e_type_mismatch);
+
+         if codegenerror then
+           exit;
+
+         p^.registersfpu:=max(p^.left^.registersfpu,p^.left^.registersfpu);
+         p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
+
+         { left must be a class }
+         if (p^.left^.resulttype^.deftype<>objectdef) or
+           not(pobjectdef(p^.left^.resulttype)^.isclass) then
+           Message(sym_e_type_mismatch);
+
+         { the operands must be related }
+         if (not(pobjectdef(p^.left^.resulttype)^.isrelated(
+           pobjectdef(pclassrefdef(p^.right^.resulttype)^.definition)))) and
+           (not(pobjectdef(pclassrefdef(p^.right^.resulttype)^.definition)^.isrelated(
+           pobjectdef(p^.left^.resulttype)))) then
+           Message(sym_e_type_mismatch);
+
+         p^.location:=p^.left^.location;
+         p^.resulttype:=pclassrefdef(p^.right^.resulttype)^.definition;
+      end;
+
+    procedure firstloadvmt(var p : ptree);
+
+      begin
+         { resulttype must be set !
+         p^.registersfpu:=0;
+         }
+         p^.registers32:=1;
+         p^.location.loc:=LOC_REGISTER;
+      end;
+
+    procedure firstraise(var p : ptree);
+
+      begin
+         p^.resulttype:=voiddef;
+         {
+         p^.registersfpu:=0;
+         p^.registers32:=0;
+         }
+         if assigned(p^.left) then
+           begin
+              firstpass(p^.left);
+
+              { this must be a _class_ }
+              if (p^.left^.resulttype^.deftype<>objectdef) or
+                ((pobjectdef(p^.left^.resulttype)^.options and oois_class)=0) then
+                Message(sym_e_type_mismatch);
+
+              p^.registersfpu:=p^.left^.registersfpu;
+              p^.registers32:=p^.left^.registers32;
+{$ifdef SUPPORT_MMX}
+              p^.registersmmx:=p^.left^.registersmmx;
+{$endif SUPPORT_MMX}
+              if assigned(p^.right) then
+                begin
+                   firstpass(p^.right);
+                   p^.right:=gentypeconvnode(p^.right,s32bitdef);
+                   firstpass(p^.right);
+                   p^.registersfpu:=max(p^.left^.registersfpu,
+                     p^.right^.registersfpu);
+                   p^.registers32:=max(p^.left^.registers32,
+                     p^.right^.registers32);
+{$ifdef SUPPORT_MMX}
+                   p^.registersmmx:=max(p^.left^.registersmmx,
+                     p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
+                end;
+           end;
+      end;
+
+    procedure firstwith(var p : ptree);
+
+      begin
+         if assigned(p^.left) and assigned(p^.right) then
+            begin
+               firstpass(p^.left);
+               if codegenerror then
+                 exit;
+
+               firstpass(p^.right);
+
+               if codegenerror then
+                 exit;
+
+               p^.registers32:=max(p^.left^.registers32,
+                 p^.right^.registers32);
+               p^.registersfpu:=max(p^.left^.registersfpu,
+                 p^.right^.registersfpu);
+{$ifdef SUPPORT_MMX}
+               p^.registersmmx:=max(p^.left^.registersmmx,
+                 p^.right^.registersmmx);
+{$endif SUPPORT_MMX}
+               p^.resulttype:=voiddef;
+            end
+         else
+           begin
+              { optimization }
+              disposetree(p);
+              p:=nil;
+           end;
+      end;
+
+{    procedure firstprocinline(var p : ptree);
+      var old_inline_proc_firsttemp : longint;
+
+      begin
+         old_inline_proc_firsttemp:=procinfo.firsttemp;
+         procinfo.firsttemp:=procinfo.firsttemp+p^.inlineproc^.definition^.localst^.datasize;
+      end; }
+
+    type
+       firstpassproc = procedure(var p : ptree);
+
+    procedure firstpass(var p : ptree);
+
+      const
+         procedures : array[ttreetyp] of firstpassproc =
+            (firstadd,firstadd,firstadd,firstmoddiv,firstadd,
+             firstmoddiv,firstassignment,firstload,firstrange,
+             firstadd,firstadd,firstadd,firstadd,
+             firstadd,firstadd,firstin,firstadd,
+             firstadd,firstshlshr,firstshlshr,firstadd,
+             firstadd,firstsubscriptn,firstderef,firstaddr,firstdoubleaddr,
+             firstordconst,firsttypeconv,firstcalln,firstnothing,
+             firstrealconst,firstfixconst,firstumminus,firstasm,firstvecn,
+             firststringconst,firstfuncret,firstselfn,
+             firstnot,firstinline,firstniln,firsterror,
+             firsttypen,firsthnewn,firsthdisposen,firstnewn,
+             firstsimplenewdispose,firstnothing,firstsetcons,firstblock,
+             firstnothing,firstnothing,firstif,firstnothing,
+             firstnothing,first_while_repeat,first_while_repeat,firstfor,
+             firstexitn,firstwith,firstcase,firstlabel,
+             firstgoto,firstsimplenewdispose,firsttryexcept,firstraise,
+             firstnothing,firsttryfinally,firstis,firstas,firstadd,
+             firstnothing,firstnothing,firstloadvmt);
+
+      var
+         oldcodegenerror : boolean;
+         oldswitches : Tcswitches;
+         { there some calls of do_firstpass in the parser }
+         oldis : pinputfile;
+         oldnr : longint;
+
+      begin
+         { if we save there the whole stuff, }
+         { line numbers become more correct  }
+         oldis:=current_module^.current_inputfile;
+         oldnr:=current_module^.current_inputfile^.line_no;
+         oldcodegenerror:=codegenerror;
+         oldswitches:=aktswitches;
+{$ifdef extdebug}
+        inc(p^.firstpasscount);
+{$endif extdebug}
+
+         codegenerror:=false;
+         current_module^.current_inputfile:=p^.inputfile;
+         current_module^.current_inputfile^.line_no:=p^.line;
+         aktswitches:=p^.pragmas;
+
+         if not(p^.error) then
+           begin
+              procedures[p^.treetype](p);
+              p^.error:=codegenerror;
+              codegenerror:=codegenerror or oldcodegenerror;
+           end
+         else codegenerror:=true;
+         aktswitches:=oldswitches;
+         current_module^.current_inputfile:=oldis;
+         current_module^.current_inputfile^.line_no:=oldnr;
+      end;
+
+    function do_firstpass(var p : ptree) : boolean;
+
+      begin
+         codegenerror:=false;
+         firstpass(p);
+         do_firstpass:=codegenerror;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:14  root
+  Initial revision
+
+  Revision 1.41  1998/03/13 22:45:59  florian
+    * small bug fixes applied
+
+  Revision 1.40  1998/03/10 23:48:36  florian
+    * a couple of bug fixes to get the compiler with -OGaxz compiler, sadly
+      enough, it doesn't run
+
+  Revision 1.39  1998/03/10 16:27:41  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.38  1998/03/10 01:11:11  peter
+    * removed one of my previous optimizations with string+char, which
+      generated wrong code
+
+  Revision 1.37  1998/03/09 10:44:38  peter
+    + string='', string<>'', string:='', string:=char optimizes (the first 2
+      were already in cg68k2)
+
+  Revision 1.36  1998/03/06 00:52:38  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.35  1998/03/04 08:38:19  florian
+    * problem with unary minus fixed
+
+  Revision 1.34  1998/03/03 01:08:31  florian
+    * bug0105 and bug0106 problem solved
+
+  Revision 1.33  1998/03/02 01:48:56  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.32  1998/03/01 22:46:14  florian
+    + some win95 linking stuff
+    * a couple of bugs fixed:
+      bug0055,bug0058,bug0059,bug0064,bug0072,bug0093,bug0095,bug0098
+
+  Revision 1.31  1998/02/28 17:26:46  carl
+    * bugfix #47 and more checking for aprocdef
+
+  Revision 1.30  1998/02/13 10:35:20  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.29  1998/02/12 17:19:16  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.28  1998/02/12 11:50:23  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.27  1998/02/11 21:56:34  florian
+    * bugfixes: bug0093, bug0053, bug0088, bug0087, bug0089
+
+  Revision 1.26  1998/02/07 23:05:03  florian
+    * once more MMX
+
+  Revision 1.25  1998/02/07 09:39:24  florian
+    * correct handling of in_main
+    + $D,$T,$X,$V like tp
+
+  Revision 1.24  1998/02/06 10:34:21  florian
+    * bug0082 and bug0084 fixed
+
+  Revision 1.23  1998/02/05 21:54:34  florian
+    + more MMX
+
+  Revision 1.22  1998/02/05 20:54:30  peter
+    * fixed a Sigsegv
+
+  Revision 1.21  1998/02/04 23:04:21  florian
+    + unary minus for mmx data types added
+
+  Revision 1.20  1998/02/04 22:00:56  florian
+    + NOT operator for mmx arrays
+
+  Revision 1.19  1998/02/04 14:38:49  florian
+    * clean up
+    * a lot of potential bugs removed adding some neccessary register allocations
+      (FPU!)
+    + allocation of MMX registers
+
+  Revision 1.18  1998/02/03 23:07:34  florian
+    * AS and IS do now a correct type checking
+    + is_convertable handles now also instances of classes
+
+  Revision 1.17  1998/02/01 19:40:51  florian
+    * clean up
+    * bug0029 fixed
+
+  Revision 1.16  1998/02/01 17:14:04  florian
+    + comparsion of class references
+
+  Revision 1.15  1998/01/30 21:23:59  carl
+    * bugfix of compiler crash with new/dispose (fourth crash of new bug)
+    * bugfix of write/read compiler crash
+
+  Revision 1.14  1998/01/25 22:29:00  florian
+    * a lot bug fixes on the DOM
+
+  Revision 1.13  1998/01/21 22:34:25  florian
+    + comparsion of Delphi classes
+
+  Revision 1.12  1998/01/21 21:29:55  florian
+    * some fixes for Delphi classes
+
+  Revision 1.11  1998/01/16 23:34:13  florian
+    + nil is compatible with class variable (tobject(x):=nil)
+
+  Revision 1.10  1998/01/16 22:34:40  michael
+  * Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
+    in this compiler :)
+
+  Revision 1.9  1998/01/13 23:11:10  florian
+    + class methods
+
+  Revision 1.8  1998/01/07 00:17:01  michael
+  Restored released version (plus fixes) as current
+
+  Revision 1.7  1997/12/10 23:07:26  florian
+  * bugs fixed: 12,38 (also m68k),39,40,41
+  + warning if a system unit is without -Us compiled
+  + warning if a method is virtual and private (was an error)
+  * some indentions changed
+  + factor does a better error recovering (omit some crashes)
+  + problem with @type(x) removed (crashed the compiler)
+
+  Revision 1.6  1997/12/09 13:54:26  carl
+  + renamed some stuff (real types mostly)
+
+  Revision 1.5  1997/12/04 12:02:19  pierre
+     + added a counter of max firstpass's for a ptree
+       for debugging only in ifdef extdebug
+
+  Revision 1.4  1997/12/03 13:53:01  carl
+  + ifdef i386.
+
+  Revision 1.3  1997/11/29 15:38:43  florian
+  * bug0033 fixed
+  * duplicate strings are now really once generated (there was a bug)
+
+  Revision 1.2  1997/11/28 11:11:43  pierre
+     negativ real constants are not supported by nasm assembler
+
+  Revision 1.1.1.1  1997/11/27 08:32:59  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
+
+  History:
+       6th september 1997:
+         + added basic support for MC68000   (CEC)
+            (lines: 189,1860,1884 + ifdef m68k)
+      19th september 1997:
+         + added evalution of constant sets  (FK)
+         + empty and constant sets are now compatible with all other
+           set types (FK)
+      20th september 1997:
+         * p^.register32 bug in firstcalln (max with register32 of p^.left i.e. args) (PM)
+      24th september 1997:
+         * line_no and inputfile are now in firstpass saved (FK)
+      25th september 1997:
+         + support of high for open arrays (FK)
+         + the high parameter is now pushed for open arrays (FK)
+      1th october 1997:
+         + added support for unary minus operator and for:=overloading (PM)
+      2nd october 1997:
+         + added handling of in_ord_x (PM)
+           boolean to byte with ord is special because the location may be different
+      3rd october 1997:
+         + renamed ret_in_eax to ret_in_acc (CEC)
+         + find ifdef m68k to find other changes (CEC)
+         * bugfix or calc correct val for regs. for m68k in firstcalln (CEC)
+      4th october 1997:
+         + added code for in_pred_x in_succ_x
+           fails for enums with jumps (PM)
+     25th october 1997:
+         + direct evalution of pred and succ with const parameter (FK)
+      6th november 1997:
+         * added typeconversion for floatdef in write(ln) for text to s64real (PM)
+         + code for str with length arg rewritten (PM)
+      13th november 1997:
+         * floatdef in write(ln) for text for different types in RTL (PM)
+         * bug causing convertability from floatdef to orddef removed (PM)
+         * typecasting from voiddef to any type not allowed anymore (PM)
+         + handling of different real const to diff realtype (PM)
+      18th november 1997:
+         * changed first_type_conv function arg as var p : ptree
+           to be able to change the tree (PM)
+}

compiler/pbase.pas

@@ -0,0 +1,242 @@
+{
+    $Id$
+    Copyright (c) 1998 by Florian Klaempfl
+
+    Contains some helper routines for the parser
+
+    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 pbase;
+
+  interface
+
+    uses
+       cobjects,globals,scanner,symtable,systems,verbose;
+
+    const
+       { forward types should only be possible inside  }
+       { a TYPE statement, this crashed the compiler   }
+       { when trying to dispose local symbols          }
+       typecanbeforward : boolean = false;
+
+       { true, if we are after an assignement }
+       afterassignment : boolean = false;
+       { sspecial for handling procedure vars }
+       getprocvar : boolean = false;
+       getprocvardef : pprocvardef = nil;
+
+    var
+       { contains the current token to be processes }
+       token : ttoken;
+
+       { size of data segment, set by proc_unit or proc_program }
+       datasize : longint;
+
+       { for operators }
+       optoken : ttoken;
+       opsym : pvarsym;
+
+       { symtable were unit references are stored }
+       refsymtable : psymtable;
+
+       { true, if only routine headers should be }
+       { parsed                    }
+       parse_only : boolean;
+
+       { true, if we are in a except block }
+       in_except_block : boolean;
+
+    { consumes token i, if the current token is unequal i }
+    { a syntax error is written                           }
+    procedure consume(i : ttoken);
+
+    { consumes all tokens til atoken (for error recovering }
+    procedure consume_all_until(atoken : ttoken);
+
+    { consumes tokens while they are semicolons }
+    procedure emptystats;
+
+    { reads a list of identifiers into a string container }
+    function idlist : pstringcontainer;
+
+    { inserts the symbols of sc in st with def as definition }
+    { sc is disposed                                         }
+    procedure insert_syms(st : psymtable;sc : pstringcontainer;def : pdef);
+
+
+  implementation
+
+
+    { consumes token i, if the current token is unequal i }
+    { a syntax error is written                           }
+    procedure consume(i : ttoken);
+
+      { generates a syntax error message }
+      procedure syntaxerror(const s : string);
+
+        begin
+           Message2(scan_f_syn_expected,tostr(get_current_col),s);
+        end;
+
+      { This is changed since I changed the order of token
+      in cobjects.pas for operator overloading !!!! }
+      { ttoken = (PLUS,MINUS,STAR,SLASH,EQUAL,GT,LT,LTE,GTE,SYMDIF,CARET,ASSIGNMENT,
+                 LECKKLAMMER,RECKKLAMMER,
+                 POINT,COMMA,LKLAMMER,RKLAMMER,COLON,SEMICOLON,
+                 KLAMMERAFFE,UNEQUAL,POINTPOINT,
+                 ID,REALNUMBER,_EOF,INTCONST,CSTRING,CCHAR,DOUBLEADDR,}
+
+
+      const tokens : array[PLUS..DOUBLEADDR] of string[12] = (
+                 '+','-','*','/','=','>','<','>=','<=','is','as','in',
+                 '><','^',':=','<>','[',']','.',',','(',')',':',';',
+                 '@','..',
+                 'identifier','const real.','end of file',
+                 'ord const','const string','const char','@@');
+
+      var
+         j : integer;
+
+      begin
+         if token<>i then
+           begin
+              if i<_AND then
+                syntaxerror(tokens[i])
+              else
+                begin
+
+                   { um die ProgrammgrӇe klein zu halten, }
+                   { wird f�r ein Schl�sselwort-Token der  }
+                   { "Text" in der Schl�sselworttabelle    }
+                   { des Scanners nachgeschaut             }
+
+                   for j:=1 to anz_keywords do
+                     if keyword_token[j]=i then
+                       syntaxerror(keyword[j])
+                end;
+           end
+         else
+           token:=yylex;
+      end;
+
+    procedure consume_all_until(atoken : ttoken);
+
+      begin
+         while (token<>atoken) and (token<>_EOF) do
+           consume(token);
+         { this will create an error if the token is _EOF }
+         if token<>atoken then
+           consume(atoken);
+         { this error is fatal as we have read the whole file }
+         Message(scan_f_end_of_file);
+      end;
+
+    procedure emptystats;
+
+      begin
+         while token=SEMICOLON do
+           consume(SEMICOLON);
+      end;
+
+    { reads a list of identifiers into a string container }
+    function idlist : pstringcontainer;
+
+      var
+        sc : pstringcontainer;
+
+      begin
+         sc:=new(pstringcontainer,init);
+         repeat
+           sc^.insert(pattern);
+           consume(ID);
+           if token=COMMA then consume(COMMA)
+             else break
+         until false;
+         idlist:=sc;
+      end;
+
+    { inserts the symbols of sc in st with def as definition }
+    { sc is disposed                                         }
+    procedure insert_syms(st : psymtable;sc : pstringcontainer;def : pdef);
+
+      var
+         s : string;
+
+      begin
+         s:=sc^.get;
+         while s<>'' do
+           begin
+              st^.insert(new(pvarsym,init(s,def)));
+              { static data fields are inserted in the globalsymtable }
+              if (st^.symtabletype=objectsymtable) and
+                 ((current_object_option and sp_static)<>0) then
+                begin
+                   s:=lowercase(st^.name^)+'_'+s;
+                   st^.defowner^.owner^.insert(new(pvarsym,init(s,def)));
+                end;
+              s:=sc^.get;
+           end;
+         dispose(sc,done);
+      end;
+
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:14  root
+  Initial revision
+
+  Revision 1.9  1998/03/10 01:17:23  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.8  1998/03/06 00:52:40  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.7  1998/03/02 01:48:59  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/16 12:51:38  michael
+  + Implemented linker object
+
+  Revision 1.5  1998/02/13 10:35:22  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.4  1998/02/12 11:50:24  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.3  1998/01/13 17:13:08  michael
+  * File time handling and file searching is now done in an OS-independent way,
+    using the new file treating functions in globals.pas.
+
+  Revision 1.2  1998/01/09 09:09:58  michael
+  + Initial implementation, second try
+
+}

compiler/pdecl.pas

@@ -0,0 +1,1769 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl
+
+    Does declaration parsing for Free Pascal
+
+    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 pdecl;
+
+  interface
+
+    uses
+      globals,symtable;
+
+    var
+       { pointer to the last read type symbol, (for "forward" }
+       { types)                                               }
+       lasttypesym : ptypesym;
+
+       { hack, which allows to use the current parsed }
+       { object type as function argument type        }
+       testcurobject : byte;
+       curobjectname : stringid;
+
+    { reads a string type with optional length }
+    { and returns a pointer to the string      }
+    { definition                               }
+    function stringtype : pdef;
+
+    { reads a string, file type or a type id and returns a name and }
+    { pdef                                                          }
+    function single_type(var s : string) : pdef;
+
+    { reads the declaration blocks }
+    procedure read_declarations(islibrary : boolean);
+
+    { reads declarations in the interface part of a unit }
+    procedure read_interface_declarations;
+
+  implementation
+
+    uses
+       cobjects,scanner,aasm,tree,pass_1,
+       types,hcodegen,verbose,systems
+{$ifdef GDB}
+       ,gdb
+{$endif GDB}
+       { parser specific stuff }
+       ,pbase,ptconst,pexpr,psub,pexports
+       { processor specific stuff }
+{$ifdef i386}
+       ,i386
+{$endif}
+{$ifdef m68k}
+       ,m68k
+{$endif}
+       ;
+
+    function read_type(const name : stringid) : pdef;forward;
+    procedure read_var_decs(is_record : boolean;do_absolute : boolean);forward;
+
+    procedure const_dec;
+
+      var
+         name : stringid;
+         p : ptree;
+         def : pdef;
+         ps : pconstset;
+         pd : pdouble;
+
+      begin
+         consume(_CONST);
+         repeat
+           name:=pattern;
+           consume(ID);
+           case token of
+              EQUAL:
+            begin
+                   consume(EQUAL);
+                   p:=expr;
+                   do_firstpass(p);
+                   case p^.treetype of
+                      ordconstn:
+                        begin
+                           if is_constintnode(p) then
+                             symtablestack^.insert(new(pconstsym,init(name,constint,p^.value,nil)))
+                           else if is_constcharnode(p) then
+                             symtablestack^.insert(new(pconstsym,init(name,constchar,p^.value,nil)))
+                           else if is_constboolnode(p) then
+                             symtablestack^.insert(new(pconstsym,init(name,constbool,p^.value,nil)))
+                           else if p^.resulttype^.deftype=enumdef then
+                             symtablestack^.insert(new(pconstsym,init(name,constord,p^.value,p^.resulttype)))
+                           else internalerror(111);
+                        end;
+                      stringconstn:
+                        {values is disposed with p so I need a copy !}
+                        symtablestack^.insert(new(pconstsym,init(name,conststring,longint(stringdup(p^.values^)),nil)));
+                      realconstn : begin
+                                      new(pd);
+                                      pd^:=p^.valued;
+                                      symtablestack^.insert(new(pconstsym,init(name,constreal,longint(pd),nil)));
+                                   end;
+                      setconstrn : begin
+                                      new(ps);
+                                      ps^:=p^.constset^;
+                                      symtablestack^.insert(new(pconstsym,init(name,
+                                        constseta,longint(ps),p^.resulttype)));
+                                   end;
+                      else Message(cg_e_illegal_expression);
+                   end;
+                   consume(SEMICOLON);
+                end;
+              COLON:
+            begin
+                   { this was missed, so const s : ^string = nil gives an
+                     error (FK)
+                   }
+                   parse_types:=true;
+                   consume(COLON);
+                   def:=read_type('');
+                   symtablestack^.insert(new(ptypedconstsym,init(name,def)));
+                   parse_types:=false;
+                   consume(EQUAL);
+                   readtypedconst(def);
+                   consume(SEMICOLON);
+                end;
+              else consume(EQUAL);
+           end;
+         until token<>ID;
+      end;
+
+    procedure label_dec;
+
+      var
+         hl : plabel;
+
+      begin
+         consume(_LABEL);
+         if not(cs_support_goto in aktswitches) then
+           Message(sym_e_goto_and_label_not_supported);
+         repeat
+           if not(token in [ID,INTCONST]) then
+             consume(ID)
+           else
+             begin
+                getlabel(hl);
+                symtablestack^.insert(new(plabelsym,init(pattern,hl)));
+                consume(token);
+             end;
+           if token<>SEMICOLON then consume(COMMA);
+         until not(token in [ID,INTCONST]);
+         consume(SEMICOLON);
+      end;
+
+    { reads a string type with optional length }
+    { and returns a pointer to the string      }
+    { definition                               }
+    function stringtype : pdef;
+
+      var
+         p : ptree;
+         d : pdef;
+
+      begin
+         consume(_STRING);
+         if token=LECKKLAMMER then
+           begin
+              consume(LECKKLAMMER);
+              p:=expr;
+              do_firstpass(p);
+              if not is_constintnode(p) then
+                Message(cg_e_illegal_expression);
+{$ifndef UseLongString}
+              if (p^.value<1) or (p^.value>255) then
+                begin
+                   Message(parser_e_string_too_long);
+                   p^.value:=255;
+                end;
+              consume(RECKKLAMMER);
+              if p^.value<>255 then
+                d:=new(pstringdef,init(p^.value))
+{$ifndef GDB}
+                 else d:=new(pstringdef,init(255));
+{$else * GDB *}
+                 else d:=globaldef('SYSTEM.STRING');
+{$endif * GDB *}
+{$else UseLongString}
+              if p^.value>255 then
+                d:=new(pstringdef,longinit(p^.value)
+              else if p^.value<>255 then
+                d:=new(pstringdef,init(p^.value))
+{$ifndef GDB}
+                 else d:=new(pstringdef,init(255));
+{$else * GDB *}
+                 else d:=globaldef('SYSTEM.STRING');
+{$endif * GDB *}
+{$endif UseLongString}
+              disposetree(p);
+           end
+{$ifndef GDB}
+                 else d:=new(pstringdef,init(255));
+{$else * GDB *}
+                 else d:=globaldef('SYSTEM.STRING');
+{$endif * GDB *}
+                 stringtype:=d;
+          end;
+
+    { reads a type definition and returns a pointer }
+    { to a appropriating pdef, s gets the name of   }
+    { the type to allow name mangling               }
+    function id_type(var s : string) : pdef;
+
+      begin
+         s:=pattern;
+         consume(ID);
+         if (testcurobject=2) and (curobjectname=pattern) then
+           begin
+              id_type:=aktobjectdef;
+              exit;
+           end;
+         getsym(s,true);
+         if assigned(srsym) then
+           begin
+                  if srsym^.typ=unitsym then
+                        begin
+                           consume(POINT);
+                           getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
+                           s:=pattern;
+                           consume(ID);
+                        end;
+                  if srsym^.typ<>typesym then
+                        begin
+                           Message(sym_e_type_id_expected);
+                           lasttypesym:=ptypesym(srsym);
+                           id_type:=generrordef;
+                           exit;
+                        end;
+           end;
+         lasttypesym:=ptypesym(srsym);
+         id_type:=ptypesym(srsym)^.definition;
+      end;
+
+    { reads a string, file type or a type id and returns a name and }
+    { pdef                                                          }
+    function single_type(var s : string) : pdef;
+
+       var
+          hs : string;
+
+       begin
+          case token of
+            _STRING:
+                begin
+                   single_type:=stringtype;
+                   s:='STRING';
+                   lasttypesym:=nil;
+                end;
+            _FILE:
+                begin
+                   consume(_FILE);
+                   if token=_OF then
+                     begin
+                        consume(_OF);
+                        single_type:=new(pfiledef,init(ft_typed,single_type(hs)));
+                        s:='FILE$OF$'+hs;
+                     end
+                   else
+                     begin
+                        { single_type:=new(pfiledef,init(ft_untyped,nil));}
+                        single_type:=cfiledef;
+                        s:='FILE';
+                     end;
+                   lasttypesym:=nil;
+                end;
+            else single_type:=id_type(s);
+         end;
+      end;
+
+    { this function parses an object or class declaration }
+    function object_dec(const n : stringid;fd : pobjectdef) : pdef;
+
+      var
+         actmembertype : symprop;
+         there_is_a_destructor : boolean;
+         is_a_class : boolean;
+         childof : pobjectdef;
+         aktclass : pobjectdef;
+
+      procedure constructor_head;
+
+        begin
+           consume(_CONSTRUCTOR);
+           { must be at same level as in implementation }
+           _proc_head(poconstructor);
+
+           if (cs_checkconsname in aktswitches) and (aktprocsym^.name<>'INIT') then
+            Message(parser_e_constructorname_must_be_init);
+
+           consume(SEMICOLON);
+             begin
+                if (aktclass^.options and oois_class)<>0 then
+                  begin
+                     { CLASS constructors return the created instance }
+                     aktprocsym^.definition^.retdef:=aktclass;
+                  end
+                else
+                  begin
+                     { OBJECT constructors return a boolean }
+{$IfDef GDB}
+                     {GDB doesn't like unnamed types !}
+                     aktprocsym^.definition^.retdef:=
+                       globaldef('boolean');
+{$Else * GDB *}
+                     aktprocsym^.definition^.retdef:=
+                        new(porddef,init(bool8bit,0,1));
+
+{$Endif * GDB *}
+                  end;
+             end;
+        end;
+
+      procedure property_dec;
+
+        var
+           sym : psym;
+           propertyparas : pdefcoll;
+
+        { returns the matching procedure to access a property }
+        function get_procdef : pprocdef;
+
+          var
+             p : pprocdef;
+
+          begin
+             p:=pprocsym(sym)^.definition;
+             get_procdef:=nil;
+             while assigned(p) do
+               begin
+                  if equal_paras(p^.para1,propertyparas) then
+                    break;
+                  p:=p^.nextoverloaded;
+               end;
+             get_procdef:=p;
+          end;
+
+        var
+           hp2,datacoll : pdefcoll;
+           p,p2 : ppropertysym;
+           overriden : psym;
+           hs : string;
+           code : word;
+           varspez : tvarspez;
+           sc : pstringcontainer;
+           hp : pdef;
+           s : string;
+
+        begin
+           { check for a class }
+           if (aktclass^.options and oois_class=0) then
+            Message(parser_e_syntax_error);
+           consume(_PROPERTY);
+           if token=ID then
+             begin
+                p:=new(ppropertysym,init(pattern));
+                consume(ID);
+                propertyparas:=nil;
+                datacoll:=nil;
+                { property parameters ? }
+                if token=LECKKLAMMER then
+                  begin
+                     { create a list of the parameters in propertyparas }
+                     consume(LECKKLAMMER);
+                     inc(testcurobject);
+                     repeat
+                       if token=_VAR then
+                         begin
+                            consume(_VAR);
+                            varspez:=vs_var;
+                         end
+                       else if token=_CONST then
+                         begin
+                            consume(_CONST);
+                            varspez:=vs_const;
+                         end
+                       else varspez:=vs_value;
+                       sc:=idlist;
+                       if token=COLON then
+                         begin
+                            consume(COLON);
+                            if token=_ARRAY then
+                              begin
+                                 if (varspez<>vs_const) and
+                                   (varspez<>vs_var) then
+                                   begin
+                                      varspez:=vs_const;
+                                      Message(parser_e_illegal_open_parameter);
+                                   end;
+                                 consume(_ARRAY);
+                                 consume(_OF);
+                                 { define range and type of range }
+                                 hp:=new(parraydef,init(0,-1,s32bitdef));
+                                 { define field type }
+                                 parraydef(hp)^.definition:=single_type(s);
+                              end
+                            else
+                              hp:=single_type(s);
+                         end
+                       else
+                         hp:=new(pformaldef,init);
+                       s:=sc^.get;
+                       while s<>'' do
+                         begin
+                            new(hp2);
+                            hp2^.paratyp:=varspez;
+                            hp2^.data:=hp;
+                            hp2^.next:=propertyparas;
+                            propertyparas:=hp2;
+                            s:=sc^.get;
+                         end;
+                       dispose(sc,done);
+                       if token=SEMICOLON then consume(SEMICOLON)
+                     else break;
+                     until false;
+                     dec(testcurobject);
+                     consume(RECKKLAMMER);
+                  end;
+                { overriden property ?                                       }
+                { force property interface, if there is a property parameter }
+                if (token=COLON) or assigned(propertyparas) then
+                  begin
+                     consume(COLON);
+                     p^.proptype:=single_type(hs);
+                     if (token=ID) and (pattern='INDEX') then
+                       begin
+                          consume(ID);
+                          p^.options:=p^.options or ppo_indexed;
+                          if token=INTCONST then
+                            val(pattern,p^.index,code);
+                          consume(INTCONST);
+                          { concat a longint to the para template }
+                          new(hp2);
+                          hp2^.paratyp:=vs_value;
+                          hp2^.data:=s32bitdef;
+                          hp2^.next:=propertyparas;
+                          propertyparas:=hp2;
+                       end;
+                  end
+                else
+                  begin
+                     { do an property override }
+                     overriden:=search_class_member(aktclass,pattern);
+                     if assigned(overriden) and (overriden^.typ=propertysym) then
+                       begin
+                          { take the whole info: }
+                          p^.options:=ppropertysym(overriden)^.options;
+                          p^.index:=ppropertysym(overriden)^.index;
+                          p^.writeaccesssym:=ppropertysym(overriden)^.writeaccesssym;
+                          p^.readaccesssym:=ppropertysym(overriden)^.readaccesssym;
+                       end
+                     else
+                       begin
+                          p^.proptype:=generrordef;
+                          message(parser_e_no_property_found_to_override);
+                       end;
+                  end;
+                if (token=ID) and (pattern='READ') then
+                  begin
+                     consume(ID);
+                     sym:=search_class_member(aktclass,pattern);
+                     if not(assigned(sym)) then
+                       Message1(sym_e_unknown_id,pattern)
+                     else
+                       begin
+                          { !!!! check sym }
+                          { varsym aren't allowed for an indexed property
+                            or an property with parameters }
+                          if ((sym^.typ=varsym) and
+                            (((p^.options and ppo_indexed)<>0) or
+                             assigned(propertyparas))) or
+                             not(sym^.typ in [varsym,procsym]) then
+                            Message(parser_e_ill_property_access_sym);
+                          { search the matching definition }
+                          if sym^.typ=procsym then
+                            begin
+                               { !!!!!! }
+                            end;
+                          p^.readaccesssym:=sym;
+                       end;
+                     consume(ID);
+                  end;
+                if (token=ID) and (pattern='WRITE') then
+                  begin
+                     consume(ID);
+                     sym:=search_class_member(aktclass,pattern);
+                     if not(assigned(sym)) then
+                       Message1(sym_e_unknown_id,pattern)
+                     else
+                       begin
+                          { !!!! check sym }
+                          if ((sym^.typ=varsym) and
+                            (((p^.options and ppo_indexed)<>0)
+                            { or property paras })) or
+                             not(sym^.typ in [varsym,procsym]) then
+                            Message(parser_e_ill_property_access_sym);
+                          { search the matching definition }
+                          if sym^.typ=procsym then
+                            begin
+                               { !!!!!! }
+                            end;
+                          p^.writeaccesssym:=sym;
+                       end;
+                     consume(ID);
+                  end;
+                if (token=ID) and (pattern='STORED') then
+                  begin
+                     consume(ID);
+                     { !!!!!!!! }
+                  end;
+                if (token=ID) and (pattern='DEFAULT') then
+                  begin
+                     consume(ID);
+                     if token=SEMICOLON then
+                       begin
+                          p2:=search_default_property(aktclass);
+                          if assigned(p2) then
+                            message1(parser_e_only_one_default_property,
+                              pobjectdef(p2^.owner^.defowner)^.name^)
+                          else
+                            begin
+                               p^.options:=p^.options and ppo_defaultproperty;
+                               if not(assigned(propertyparas)) then
+                                 message(parser_e_property_need_paras);
+                            end;
+                       end
+                     else
+                       begin
+                          { !!!!!!! storage }
+                       end;
+                     consume(SEMICOLON);
+                  end
+                else if (token=ID) and (pattern='NODEFAULT') then
+                  begin
+                     consume(ID);
+                     { !!!!!!!! }
+                  end;
+                symtablestack^.insert(p);
+                { clean up }
+                if assigned(datacoll) then
+                  dispose(datacoll);
+             end
+           else
+              consume(ID);
+           consume(SEMICOLON);
+        end;
+
+      procedure destructor_head;
+
+        begin
+           consume(_DESTRUCTOR);
+           if (cs_checkconsname in aktswitches) and (aktprocsym^.name<>'DONE') then
+            Message(parser_e_destructorname_must_be_done);
+
+           _proc_head(podestructor);
+           consume(SEMICOLON);
+           if assigned(aktprocsym^.definition^.para1) then
+            Message(parser_e_no_paras_for_destructor);
+           { no return value }
+           aktprocsym^.definition^.retdef:=voiddef;
+        end;
+
+      procedure object_komponenten;
+
+        var
+           oldparse_only : boolean;
+
+        begin
+           repeat
+             case token of
+                ID:
+                  begin
+                     if (pattern='PUBLIC') or
+                       (pattern='PUBLISHED') or
+                       (pattern='PROTECTED') or
+                       (pattern='PRIVATE') then
+                       exit;
+                     read_var_decs(false,false);
+                  end;
+                _PROPERTY:
+                  property_dec;
+                _PROCEDURE,_FUNCTION,_CLASS:
+                  begin
+                     oldparse_only:=parse_only;
+                     parse_only:=true;
+                     proc_head;
+                     parse_only:=oldparse_only;
+                     if (token=ID) and
+                       ((pattern='VIRTUAL') or (pattern='DYNAMIC')) then
+                       begin
+                          if actmembertype=sp_private then
+                           Message(parser_w_priv_meth_not_virtual);
+                          consume(ID);
+                          consume(SEMICOLON);
+                          aktprocsym^.definition^.options:=
+                            aktprocsym^.definition^.options or povirtualmethod;
+                          aktclass^.options:=aktclass^.options or oo_hasvirtual;
+                       end
+                     else if (token=ID) and (pattern='OVERRIDE') then
+                       begin
+                          consume(ID);
+                          consume(SEMICOLON);
+                          aktprocsym^.definition^.options:=
+                            aktprocsym^.definition^.options or pooverridingmethod or povirtualmethod;
+                       end;
+                     { Delphi II extension }
+                     if (token=ID) and (pattern='ABSTRACT') then
+                       begin
+                          consume(ID);
+                          consume(SEMICOLON);
+                          if (aktprocsym^.definition^.options and povirtualmethod)<>0 then
+                            begin
+                               aktprocsym^.definition^.options:=
+                                aktprocsym^.definition^.options or
+                                  poabstractmethod;
+                            end
+                          else
+                            Message(parser_e_only_virtual_methods_abstract);
+                          { the method is defined }
+                          aktprocsym^.definition^.forwarddef:=false;
+                       end;
+                     if (token=ID) and (pattern='STATIC') and
+                        (cs_static_keyword in aktswitches) then
+                       begin
+                          consume(ID);
+                          consume(SEMICOLON);
+                          aktprocsym^.properties:=
+                            aktprocsym^.properties or
+                              sp_static;
+                          aktprocsym^.definition^.options:=
+                            aktprocsym^.definition^.options or
+                               postaticmethod;
+                       end;
+                  end;
+                _CONSTRUCTOR:
+                  begin
+                     if actmembertype<>sp_public then
+                       Message(parser_e_constructor_cannot_be_private);
+                     oldparse_only:=parse_only;
+                     parse_only:=true;
+                     constructor_head;
+                     parse_only:=oldparse_only;
+                  end;
+                _DESTRUCTOR:
+                  begin
+                     if there_is_a_destructor then
+                      Message(parser_n_only_one_destructor);
+                     there_is_a_destructor:=true;
+
+                     if actmembertype<>sp_public then
+                      Message(parser_e_destructor_cannot_be_private);
+                     oldparse_only:=parse_only;
+                     parse_only:=true;
+                     destructor_head;
+                     parse_only:=oldparse_only;
+                     if (token=ID) and
+                       ((pattern='VIRTUAL') or (pattern='DYNAMIC')) then
+                       begin
+                          consume(ID);
+                          consume(SEMICOLON);
+                          aktprocsym^.definition^.options:=
+                            aktprocsym^.definition^.options or povirtualmethod;
+                       end
+                     else if (token=ID) and (pattern='OVERRIDE') then
+                       begin
+                          consume(ID);
+                          consume(SEMICOLON);
+                          aktprocsym^.definition^.options:=
+                            aktprocsym^.definition^.options or pooverridingmethod or povirtualmethod;
+                       end;
+                  end;
+                _END : exit;
+                else Message(parser_e_syntax_error);
+             end;
+           until false;
+        end;
+
+      var
+         hs : string;
+         pcrd : pclassrefdef;
+         hp1 : pdef;
+         oldprocsym:Pprocsym;
+
+      begin
+         {Nowadays aktprocsym may already have a value, so we need to save
+          it.}
+         oldprocsym:=aktprocsym;
+         { forward is resolved }
+         if assigned(fd) then
+           fd^.options:=fd^.options and not(oo_isforward);
+
+         there_is_a_destructor:=false;
+         actmembertype:=sp_public;
+
+         { objects and class types can't be declared local }
+         if (symtablestack^.symtabletype<>globalsymtable) and
+           (symtablestack^.symtabletype<>staticsymtable) then
+           Message(parser_e_no_local_objects);
+
+         { distinguish classes and objects }
+         if token=_OBJECT then
+           begin
+              is_a_class:=false;
+              consume(_OBJECT)
+           end
+         else
+           begin
+              is_a_class:=true;
+              consume(_CLASS);
+              if not(assigned(fd)) and (token=_OF) then
+                begin
+                   { a hack, but it's easy to handle }
+                   { class reference type }
+                   consume(_OF);
+                   if typecanbeforward then
+                     forwardsallowed:=true;
+                   hp1:=single_type(hs);
+
+                   { accept hp1, if is a forward def ...}
+                   if ((lasttypesym<>nil)
+                       and ((lasttypesym^.properties and sp_forwarddef)<>0)) or
+                   { or a class
+                     (if the foward defined type is a class is checked, when
+                      the forward is resolved)
+                   }
+                     ((hp1^.deftype=objectdef) and (
+                     (pobjectdef(hp1)^.options and oois_class)<>0)) then
+                     begin
+                        pcrd:=new(pclassrefdef,init(hp1));
+                    object_dec:=pcrd;
+                        {I add big troubles here
+                        with var p : ^byte in graph.putimage
+                        because a save_forward was called and
+                        no resolve forward
+                        => so the definition was rewritten after
+                        having been disposed !!
+                        Strange problems appeared !!!!}
+                        {Anyhow forwards should only be allowed
+                        inside a type statement ??
+                        don't you think so }
+                        if (lasttypesym<>nil)
+                          and ((lasttypesym^.properties and sp_forwarddef)<>0) then
+                            lasttypesym^.forwardpointer:=ppointerdef(pcrd);
+                        forwardsallowed:=false;
+                     end
+                   else
+                     begin
+                        Message(parser_e_class_type_expected);
+                        object_dec:=new(perrordef,init);
+                     end;
+                   exit;
+                end
+              { forward class }
+              else if not(assigned(fd)) and (token=SEMICOLON) then
+                begin
+                   { also anonym objects aren't allow (o : object a : longint; end;) }
+                   if n='' then
+                    Message(parser_e_no_anonym_objects);
+                   if n='TOBJECT' then
+                     begin
+                        aktclass:=new(pobjectdef,init(n,nil));
+                        class_tobject:=aktclass;
+                     end
+                   else
+                     aktclass:=new(pobjectdef,init(n,class_tobject));
+                   aktclass^.options:=aktclass^.options or oois_class or oo_isforward;
+                   object_dec:=aktclass;
+                   exit;
+                end;
+           end;
+
+         { also anonym objects aren't allow (o : object a : longint; end;) }
+         if n='' then
+           Message(parser_e_no_anonym_objects);
+
+         { read the parent class }
+         if token=LKLAMMER then
+           begin
+              consume(LKLAMMER);
+              { does not allow objects.tobject !! }
+              {if token<>ID then
+                consume(ID);
+              getsym(pattern,true);}
+              childof:=pobjectdef(id_type(pattern));
+              if (childof^.deftype<>objectdef) then
+                 begin
+                    Message(parser_e_class_type_expected);
+                    childof:=nil;
+                 end;
+                   { a mix of class and object isn't allowed }
+              if (((childof^.options and oois_class)<>0) and not is_a_class) or
+                 (((childof^.options and oois_class)=0) and is_a_class) then
+                Message(parser_e_mix_of_classes_and_objects);
+              consume(RKLAMMER);
+              if assigned(fd) then
+                begin
+                   fd^.childof:=childof;
+                   aktclass:=fd;
+                end
+              else
+                aktclass:=new(pobjectdef,init(n,childof));
+           end
+         { if no parent class, then a class get tobject as parent }
+         else if is_a_class then
+           begin
+              { is the current class tobject?        }
+              { so you could define your own tobject }
+              if n='TOBJECT' then
+                begin
+                   if assigned(fd) then
+                     aktclass:=fd
+                   else
+                     aktclass:=new(pobjectdef,init(n,nil));
+                   class_tobject:=aktclass;
+                end
+              else
+                begin
+                   childof:=class_tobject;
+                   if assigned(fd) then
+                     begin
+                        aktclass:=fd;
+                        aktclass^.childof:=childof;
+                     end
+                   else
+                     aktclass:=new(pobjectdef,init(n,childof));
+                end;
+           end
+         else aktclass:=new(pobjectdef,init(n,nil));
+
+         { set the class attribute }
+         if is_a_class then
+           aktclass^.options:=aktclass^.options or oois_class;
+
+
+         aktobjectdef:=aktclass;
+
+         { default access is public }
+         actmembertype:=sp_public;
+         aktclass^.publicsyms^.next:=symtablestack;
+         symtablestack:=aktclass^.publicsyms;
+         procinfo._class:=aktclass;
+         testcurobject:=1;
+         curobjectname:=n;
+         while token<>_END do
+           begin
+              if (token=ID) and (pattern='PRIVATE') then
+                begin
+                   consume(ID);
+                   actmembertype:=sp_private;
+                   current_object_option:=sp_private;
+                end;
+              if (token=ID) and (pattern='PROTECTED') then
+                begin
+                   consume(ID);
+                   current_object_option:=sp_protected;
+                   actmembertype:=sp_protected;
+                end;
+              if (token=ID) and (pattern='PUBLIC') then
+                begin
+                   consume(ID);
+                   current_object_option:=sp_public;
+                   actmembertype:=sp_public;
+                end;
+              if (token=ID) and (pattern='PUBLISHED') then
+                begin
+                   consume(ID);
+                   current_object_option:=sp_public;
+                   actmembertype:=sp_public;
+                end;
+              object_komponenten;
+           end;
+         current_object_option:=sp_public;
+         consume(_END);
+         testcurobject:=0;
+         curobjectname:='';
+
+{$ifdef MAKELIB}
+        datasegment^.concat(new(pai_cut,init));
+{$endif MAKELIB}
+{$ifdef GDB}
+         { generate the VMT }
+         if cs_debuginfo in aktswitches then
+           begin
+              do_count_dbx:=true;
+              if assigned(aktclass^.owner) and assigned(aktclass^.owner^.name) then
+               debuglist^.concat(new(pai_stabs,init(strpnew('"vmt_'+aktclass^.owner^.name^+n+':S'+
+                typeglobalnumber('__vtbl_ptr_type')+'",'+tostr(N_STSYM)+',0,0,'+aktclass^.vmt_mangledname))));
+           end;
+{$endif * GDB *}
+         datasegment^.concat(new(pai_symbol,init_global(aktclass^.vmt_mangledname)));
+
+         { determine the size with publicsyms^.datasize, because }
+         { size gives back 4 for CLASSes                         }
+         datasegment^.concat(new(pai_const,init_32bit(aktclass^.publicsyms^.datasize)));
+         datasegment^.concat(new(pai_const,init_32bit(-aktclass^.publicsyms^.datasize)));
+
+         { write pointer to parent VMT, this isn't implemented in TP }
+         { but this is not used in FPC ? (PM) }
+         { it's not used yet, but the delphi-operators as and is need it (FK) }
+         if assigned(aktclass^.childof) then
+           begin
+              datasegment^.concat(new(pai_const,init_symbol(strpnew(aktclass^.childof^.vmt_mangledname))));
+              if aktclass^.childof^.owner^.symtabletype=unitsymtable then
+                concat_external(aktclass^.childof^.vmt_mangledname,EXT_NEAR);
+           end
+         else
+           datasegment^.concat(new(pai_const,init_32bit(0)));
+
+         { this generates the entries }
+         genvmt(aktclass);
+
+         { restore old state }
+         symtablestack:=symtablestack^.next;
+         procinfo._class:=nil;
+         {Restore the aktprocsym.}
+         aktprocsym:=oldprocsym;
+
+         object_dec:=aktclass;
+      end;
+
+    { reads a record declaration }
+    function record_dec : pdef;
+
+      var
+         symtable : psymtable;
+
+      begin
+         symtable:=new(psymtable,init(recordsymtable));
+         symtable^.next:=symtablestack;
+         symtablestack:=symtable;
+         consume(_RECORD);
+         read_var_decs(true,false);
+
+         { may be scale record size to a size of n*4 ? }
+         if ((symtablestack^.datasize mod aktpackrecords)<>0) then
+           inc(symtablestack^.datasize,aktpackrecords-(symtablestack^.datasize mod aktpackrecords));
+
+         consume(_END);
+         symtablestack:=symtable^.next;
+         record_dec:=new(precdef,init(symtable));
+      end;
+
+    { reads a type definition and returns a pointer to it }
+    function read_type(const name : stringid) : pdef;
+
+    function handle_procvar:Pprocvardef;
+
+    var
+       sc : pstringcontainer;
+       s : string;
+       p : pdef;
+       varspez : tvarspez;
+       procvardef : pprocvardef;
+
+    begin
+       procvardef:=new(pprocvardef,init);
+       if token=LKLAMMER then
+         begin
+            consume(LKLAMMER);
+            inc(testcurobject);
+            repeat
+              if token=_VAR then
+                begin
+                   consume(_VAR);
+                   varspez:=vs_var;
+                end
+              else if token=_CONST then
+                begin
+                   consume(_CONST);
+                   varspez:=vs_const;
+                end
+              else varspez:=vs_value;
+              sc:=idlist;
+              if token=COLON then
+                begin
+                   consume(COLON);
+                   if token=_ARRAY then
+                     begin
+                        if (varspez<>vs_const) and
+                          (varspez<>vs_var) then
+                          begin
+                             varspez:=vs_const;
+                             Message(parser_e_illegal_open_parameter);
+                          end;
+                        consume(_ARRAY);
+                        consume(_OF);
+                        { define range and type of range }
+                        p:=new(parraydef,init(0,-1,s32bitdef));
+                        { define field type }
+                        parraydef(p)^.definition:=single_type(s);
+                     end
+                   else
+                     p:=single_type(s);
+                end
+              else
+                p:=new(pformaldef,init);
+              s:=sc^.get;
+              while s<>'' do
+                begin
+                   procvardef^.concatdef(p,varspez);
+                   s:=sc^.get;
+                end;
+              dispose(sc,done);
+              if token=SEMICOLON then consume(SEMICOLON)
+            else break;
+            until false;
+            dec(testcurobject);
+            consume(RKLAMMER);
+         end;
+       handle_procvar:=procvardef;
+    end;
+
+      var
+         hp1,p : pdef;
+         pt : ptree;
+         aufdef : penumdef;
+         aufsym : penumsym;
+         ap : parraydef;
+         s : stringid;
+         l,v,oldaktpackrecords : longint;
+         hs : string;
+
+      procedure range_type;
+
+        begin
+           { it can be only a range type }
+           pt:=expr;
+           do_firstpass(pt);
+
+           { valid expression ? }
+           if (pt^.treetype<>rangen) or
+              (pt^.left^.treetype<>ordconstn) then
+             Begin
+               Message(sym_e_error_in_type_def);
+               { Here we create a node type with a range of 0  }
+               { To make sure that no crashes will occur later }
+               { on in the compiler.                           }
+               p:=new(porddef,init(uauto,0,0));
+             end
+           else
+             p:=new(porddef,init(uauto,pt^.left^.value,pt^.right^.value));
+           disposetree(pt);
+        end;
+
+      begin
+         case token of
+            ID,_STRING,_FILE:
+              p:=single_type(hs);
+            LKLAMMER:
+              begin
+                 consume(LKLAMMER);
+                 l:=-1;
+                 aufsym := Nil;
+                 aufdef:=new(penumdef,init);
+                 repeat
+                   s:=pattern;
+                   consume(ID);
+                   if token=ASSIGNMENT then
+                     begin
+                        consume(ASSIGNMENT);
+                        v:=get_intconst;
+                        { please leave that a note, allows type save }
+                        { declarations in the win32 units !          }
+                        if v<=l then
+                         Message(parser_n_duplicate_enum);
+                        l:=v;
+                     end
+                   else
+                     inc(l);
+                   constsymtable^.insert(new(penumsym,init(s,aufdef,l)));
+                   if token=COMMA then
+                     consume(COMMA)
+                   else
+                     break;
+                 until false;
+                 aufdef^.max:=l;
+                 p:=aufdef;
+                 consume(RKLAMMER);
+              end;
+            _ARRAY:
+              begin
+                 consume(_ARRAY);
+                 consume(LECKKLAMMER);
+                 p:=nil;
+                 repeat
+                   { read the expression and check it }
+                   pt:=expr;
+                   if pt^.treetype=typen then
+                     begin
+                        if pt^.resulttype^.deftype=enumdef then
+                          begin
+                             if p=nil then
+                               begin
+                                  ap:=new(parraydef,
+                                    init(0,penumdef(pt^.resulttype)^.max,pt^.resulttype));
+                                  p:=ap;
+                               end
+                             else
+                               begin
+                                  ap^.definition:=new(parraydef,
+                                    init(0,penumdef(pt^.resulttype)^.max,pt^.resulttype));
+                                  ap:=parraydef(ap^.definition);
+                               end;
+                          end
+                        else if pt^.resulttype^.deftype=orddef then
+                          begin
+                             case porddef(pt^.resulttype)^.typ of
+                                s8bit,u8bit,s16bit,u16bit,s32bit :
+                                  begin
+                                     if p=nil then
+                                       begin
+                                          ap:=new(parraydef,init(porddef(pt^.resulttype)^.von,
+                                            porddef(pt^.resulttype)^.bis,pt^.resulttype));
+                                          p:=ap;
+                                       end
+                                     else
+                                       begin
+                                          ap^.definition:=new(parraydef,init(porddef(pt^.resulttype)^.von,
+                                            porddef(pt^.resulttype)^.bis,pt^.resulttype));
+                                          ap:=parraydef(ap^.definition);
+                                       end;
+                                  end;
+                                bool8bit:
+                                  begin
+                                     if p=nil then
+                                       begin
+                                          ap:=new(parraydef,init(0,1,pt^.resulttype));
+                                          p:=ap;
+                                       end
+                                     else
+                                       begin
+                                          ap^.definition:=new(parraydef,init(0,1,pt^.resulttype));
+                                          ap:=parraydef(ap^.definition);
+                                       end;
+                                  end;
+                                uchar:
+                                  begin
+                                           if p=nil then
+                                                                                             begin
+                                                ap:=new(parraydef,init(0,255,pt^.resulttype));
+                                                                                                    p:=ap;
+                                             end
+                                           else
+                                             begin
+                                                ap^.definition:=new(parraydef,init(0,255,pt^.resulttype));
+                                                ap:=parraydef(ap^.definition);
+                                             end;
+                                                                                    end;
+                                else Message(sym_e_error_in_type_def);
+                             end;
+                          end
+                        else Message(sym_e_error_in_type_def);
+                     end
+                   else
+                     begin
+                        do_firstpass(pt);
+
+                        if (pt^.treetype<>rangen) or
+                           (pt^.left^.treetype<>ordconstn) then
+                          Message(sym_e_error_in_type_def);
+                        { Registrierung der Grenzen erzwingen: }
+                        {$IfNdef GDB}
+                        if pt^.right^.resulttype=pdef(s32bitdef) then
+                          pt^.right^.resulttype:=new(porddef,init(
+                            s32bit,$80000000,$7fffffff));
+                        {$EndIf GDB}
+                        if p=nil then
+                          begin
+                             ap:=new(parraydef,init(pt^.left^.value,pt^.right^.value,pt^.right^.resulttype));
+                             p:=ap;
+                          end
+                        else
+                          begin
+                             ap^.definition:=new(parraydef,init(pt^.left^.value,pt^.right^.value,pt^.right^.resulttype));
+                             ap:=parraydef(ap^.definition);
+                          end;
+                     end;
+                   disposetree(pt);
+
+                   if token=COMMA then consume(COMMA)
+                     else break;
+                 until false;
+                 consume(RECKKLAMMER);
+                 consume(_OF);
+                 hp1:=read_type('');
+                 { if no error, set element type }
+                 if assigned(ap) then
+                   ap^.definition:=hp1;
+                  end;
+            _SET:
+              begin
+                 consume(_SET);
+                 consume(_OF);
+                 hp1:=read_type('');
+                 case hp1^.deftype of
+                    enumdef : p:=new(psetdef,init(hp1,penumdef(hp1)^.max));
+                    orddef : begin
+                                  case porddef(hp1)^.typ of
+                                     uchar : p:=new(psetdef,init(hp1,255));
+                                     u8bit,s8bit,u16bit,s16bit,s32bit :
+                                       begin
+                                          if (porddef(hp1)^.von>=0) then
+                                            p:=new(psetdef,init(hp1,porddef(hp1)^.bis))
+                                          else Message(sym_e_ill_type_decl_set);
+                                       end;
+                                  else Message(sym_e_ill_type_decl_set);
+                                  end;
+                               end;
+                    else Message(sym_e_ill_type_decl_set);
+                 end;
+              end;
+            CARET:
+              begin
+                 consume(CARET);
+                 { forwards allowed only inside TYPE statements }
+                 if typecanbeforward then
+                    forwardsallowed:=true;
+                 hp1:=single_type(hs);
+                 p:=new(ppointerdef,init(hp1));
+{$ifndef GDB}
+                 if lasttypesym<>nil then
+                   save_forward(ppointerdef(p),lasttypesym);
+{$else * GDB *}
+                 {I add big troubles here
+                 with var p : ^byte in graph.putimage
+                 because a save_forward was called and
+                 no resolve forward
+                 => so the definition was rewritten after
+                 having been disposed !!
+                 Strange problems appeared !!!!}
+                 {Anyhow forwards should only be allowed
+                 inside a type statement ??
+                 don't you think so }
+                 if (lasttypesym<>nil)
+                   and ((lasttypesym^.properties and sp_forwarddef)<>0) then
+                     lasttypesym^.forwardpointer:=ppointerdef(p);
+{$endif * GDB *}
+                 forwardsallowed:=false;
+              end;
+            _RECORD:
+              p:=record_dec;
+            _PACKED:
+              begin
+                 consume(_PACKED);
+                 oldaktpackrecords:=aktpackrecords;
+                 aktpackrecords:=1;
+                 p:=record_dec;
+                 aktpackrecords:=oldaktpackrecords;
+              end;
+            _CLASS,
+            _OBJECT:
+              p:=object_dec(name,nil);
+            _PROCEDURE:
+              begin
+                 consume(_PROCEDURE);
+                 p:=handle_procvar;
+              end;
+            _FUNCTION:
+              begin
+                 consume(_FUNCTION);
+                 p:=handle_procvar;
+                 consume(COLON);
+                 pprocvardef(p)^.retdef:=single_type(hs);
+              end;
+            else
+              range_type;
+         end;
+         read_type:=p;
+      end;
+
+    { search in symtablestack used, but not defined type }
+    procedure testforward_types(p : psym);{$ifndef FPC}far;{$endif}
+
+      begin
+         if (p^.typ=typesym) and ((p^.properties and sp_forwarddef)<>0) then
+           Message(sym_e_type_id_not_defined);
+      end;
+
+    { reads a type declaration to the symbol table }
+    procedure type_dec;
+
+      var
+         typename : stringid;
+{$ifdef dummy}
+         olddef,newdef : pdef;
+         s : string;
+{$endif dummy}
+
+      begin
+         parse_types:=true;
+         consume(_TYPE);
+         typecanbeforward:=true;
+         repeat
+           typename:=pattern;
+           consume(ID);
+           consume(EQUAL);
+             { here you loose the strictness of pascal
+             for which a redefinition like
+               childtype = parenttype;
+                           child2type = parenttype;
+             does not make the two child types equal !!
+             here all vars from childtype and child2type
+             get the definition of parenttype !!            }
+{$ifdef testequaltype}
+           if (token = ID) or (token=_FILE) or (token=_STRING) then
+             begin
+                olddef := single_type(s);
+                { make a clone of olddef }
+                { is that ok ??? }
+                getmem(newdef,SizeOf(olddef));
+                move(olddef^,newdef^,SizeOf(olddef));
+                symtablestack^.insert(new(ptypesym,init(typename,newdef)));
+             end
+           else
+{$endif testequaltype}
+             begin
+                getsym(typename,false);
+                { check if it is the definition of a forward defined class }
+                if assigned(srsym) and (token=_CLASS) and
+                  (srsym^.typ=typesym) and
+                  (ptypesym(srsym)^.definition^.deftype=objectdef) and
+                  ((pobjectdef(ptypesym(srsym)^.definition)^.options and oo_isforward)<>0) and
+                  ((pobjectdef(ptypesym(srsym)^.definition)^.options and oois_class)<>0) then
+                  begin
+                     { we can ignore the result   }
+                     { the definition is modified }
+                     object_dec(typename,pobjectdef(ptypesym(srsym)^.definition));
+                  end
+                else
+                  symtablestack^.insert(new(ptypesym,init(typename,read_type(typename))));
+             end;
+           consume(SEMICOLON);
+         until token<>ID;
+         typecanbeforward:=false;
+{$ifdef tp}
+         symtablestack^.foreach(testforward_types);
+{$else}
+         symtablestack^.foreach(@testforward_types);
+{$endif}
+         resolve_forwards;
+         parse_types:=false;
+      end;
+
+    { parses varaible declarations and inserts them in }
+    { the top symbol table of symtablestack            }
+    procedure var_dec;
+
+      {var
+         p : pdef;
+         sc : pstringcontainer;      }
+
+      begin
+         consume(_VAR);
+         read_var_decs(false,true);
+      end;
+
+    { reads the filed of a record into a        }
+    { symtablestack, if record=false            }
+    { variants are forbidden, so this procedure }
+    { can be used to read object fields         }
+    { if absolute is true, ABSOLUTE and file    }
+    { types are allowed                         }
+    { => the procedure is also used to read     }
+    { a sequence of variable declaration        }
+    procedure read_var_decs(is_record : boolean;do_absolute : boolean);
+
+      var
+         sc : pstringcontainer;
+         s : stringid;
+         l    : longint;
+         code : word;
+         hs : string;
+         p,casedef : pdef;
+         { maxsize contains the max. size of a variant }
+         { startvarrec contains the start of the variant part of a record }
+         maxsize,startvarrec : longint;
+         pt : ptree;
+         old_parse_types : boolean;
+         { to handle absolute }
+         abssym : pabsolutesym;
+
+      begin
+         hs:='';
+         old_parse_types:=parse_types;
+         parse_types:=true;
+         while (token=ID) and
+           (pattern<>'PUBLIC') and
+           (pattern<>'PRIVATE') and
+           (pattern<>'PUBLISHED') and
+           (pattern<>'PROTECTED') do
+           begin
+              sc:=idlist;
+              consume(COLON);
+              p:=read_type('');
+              if do_absolute and (token=ID) and (pattern='ABSOLUTE') then
+                begin
+                   s:=sc^.get;
+                   if sc^.get<>'' then
+                    Message(parser_e_absolute_only_one_var);
+                   dispose(sc,done);
+                   consume(ID);
+                   if token=ID then
+                     begin
+                        getsym(pattern,true);
+                        consume(ID);
+                        { we should check the result type of srsym }
+                        if not (srsym^.typ in [varsym,typedconstsym]) then
+                         Message(parser_e_absolute_only_to_var_or_const);
+                        abssym:=new(pabsolutesym,init(s,p));
+                        abssym^.typ:=absolutesym;
+                        abssym^.abstyp:=tovar;
+                        abssym^.ref:=srsym;
+                        symtablestack^.insert(abssym);
+                     end
+                   else
+                   if token=CSTRING then
+                     begin
+                        abssym:=new(pabsolutesym,init(s,p));
+                        s:=pattern;
+                        consume(CSTRING);
+                        abssym^.typ:=absolutesym;
+                        abssym^.abstyp:=toasm;
+                        abssym^.asmname:=stringdup(s);
+                        symtablestack^.insert(abssym);
+                     end
+                   else
+                   { absolute address ?!? }
+                   if token=INTCONST then
+                     begin
+                       if (target_info.target=target_GO32V2) then
+                        begin
+                          abssym:=new(pabsolutesym,init(s,p));
+                          abssym^.typ:=absolutesym;
+                          abssym^.abstyp:=toaddr;
+                          abssym^.absseg:=false;
+                          s:=pattern;
+                          consume(INTCONST);
+                          val(s,abssym^.address,code);
+                          if token=COLON then
+                           begin
+                             consume(token);
+                             s:=pattern;
+                             consume(INTCONST);
+                             val(s,l,code);
+                             abssym^.address:=abssym^.address shl 4+l;
+                             abssym^.absseg:=true;
+                           end;
+                          symtablestack^.insert(abssym);
+                        end
+                       else
+                        Message(parser_e_absolute_only_to_var_or_const);
+                     end
+                   else
+                     Message(parser_e_absolute_only_to_var_or_const);
+                end
+              else
+                begin
+                   if token=SEMICOLON then
+                     begin
+                        if (symtablestack^.symtabletype=objectsymtable) then
+                          begin
+                             consume(SEMICOLON);
+                             if (token=ID) and (pattern='STATIC') and
+                                (cs_static_keyword in aktswitches) then
+                               begin
+                                  current_object_option:=current_object_option or sp_static;
+                                  insert_syms(symtablestack,sc,p);
+                                  current_object_option:=current_object_option - sp_static;
+                                  consume(ID);
+                                  consume(SEMICOLON);
+                               end
+                             else
+                               { this will still be a the wrong line !! }
+                               insert_syms(symtablestack,sc,p);
+                          end
+                        else
+                          begin
+                             { at the right line }
+                             insert_syms(symtablestack,sc,p);
+                             consume(SEMICOLON);
+                          end
+                     end
+                   else
+                     begin
+                        insert_syms(symtablestack,sc,p);
+                        if not(is_record) then
+                          consume(SEMICOLON);
+                     end;
+                end;
+              while token=SEMICOLON do
+                consume(SEMICOLON);
+           end;
+         if (token=_CASE) and is_record then
+           begin
+              maxsize:=0;
+              consume(_CASE);
+              s:=pattern;
+              getsym(s,false);
+              { may be only a type: }
+              if assigned(srsym) and ((srsym^.typ=typesym) or
+              { and with unit qualifier: }
+                (srsym^.typ=unitsym)) then
+                begin
+                   casedef:=read_type('');
+                end
+              else
+                begin
+                   consume(ID);
+                   consume(COLON);
+
+                   casedef:=read_type('');
+                   symtablestack^.insert(new(pvarsym,init(s,casedef)));
+                end;
+              if not is_ordinal(casedef) then
+               Message(parser_e_ordinal_expected);
+
+              consume(_OF);
+              startvarrec:=symtablestack^.datasize;
+              repeat
+                repeat
+                  pt:=expr;
+                  do_firstpass(pt);
+                  if not(pt^.treetype=ordconstn) then
+                    Message(cg_e_illegal_expression);
+                  disposetree(pt);
+                  if token=COMMA then consume(COMMA)
+                    else break;
+                until false;
+                consume(COLON);
+                consume(LKLAMMER);
+                if token<>RKLAMMER then
+                  read_var_decs(true,false);
+
+                { calculates maximal variant size }
+                maxsize:=max(maxsize,symtablestack^.datasize);
+
+                { the items of the next variant are overlayed }
+                symtablestack^.datasize:=startvarrec;
+                consume(RKLAMMER);
+                if token<>SEMICOLON then
+                  break
+                else
+                  consume(SEMICOLON);
+                while token=SEMICOLON do
+                  consume(SEMICOLON);
+              until (token=_END) or (token=RKLAMMER);
+
+              { at last set the record size to that of the biggest variant }
+              symtablestack^.datasize:=maxsize;
+           end;
+         parse_types:=old_parse_types;
+      end;
+
+    procedure read_declarations(islibrary : boolean);
+
+      begin
+         repeat
+           case token of
+              _LABEL : label_dec;
+              _CONST : const_dec;
+              _TYPE : type_dec;
+              _VAR : var_dec;
+              _CONSTRUCTOR,_DESTRUCTOR,
+              _FUNCTION,_PROCEDURE,_OPERATOR,_CLASS : unter_dec;
+              _EXPORTS : if islibrary then
+                           read_exports
+                         else
+                           break;
+              else break;
+           end;
+         until false;
+      end;
+
+    procedure read_interface_declarations;
+
+      begin
+         {Since the body is now parsed at lexlevel 1, and the declarations
+          must be parsed at the same lexlevel we increase the lexlevel.}
+         inc(lexlevel);
+         repeat
+           case token of
+              _CONST : const_dec;
+              _TYPE : type_dec;
+              _VAR : var_dec;
+              { should we allow operator in interface ? }
+              { of course otherwise you cannot          }
+              { declare an operator usable by other     }
+              { units or progs                       PM }
+              _FUNCTION,_PROCEDURE,_OPERATOR : unter_dec;
+              else
+                 break;
+           end;
+         until false;
+         dec(lexlevel);
+      end;
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:14  root
+  Initial revision
+
+  Revision 1.31  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.30  1998/03/21 23:59:39  florian
+    * indexed properties fixed
+    * ppu i/o of properties fixed
+    * field can be also used for write access
+    * overriding of properties
+
+  Revision 1.29  1998/03/18 22:50:11  florian
+    + fstp/fld optimization
+    * routines which contains asm aren't longer optimzed
+    * wrong ifdef TEST_FUNCRET corrected
+    * wrong data generation for array[0..n] of char = '01234'; fixed
+    * bug0097 is fixed partial
+    * bug0116 fixed (-Og doesn't use enter of the stack frame is greater than
+      65535)
+
+  Revision 1.28  1998/03/10 16:27:41  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.27  1998/03/10 01:17:23  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.26  1998/03/06 00:52:41  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.25  1998/03/05 22:43:49  florian
+    * some win32 support stuff added
+
+  Revision 1.24  1998/03/04 17:33:49  michael
+  + Changed ifdef FPK to ifdef FPC
+
+  Revision 1.23  1998/03/04 01:35:06  peter
+    * messages for unit-handling and assembler/linker
+    * the compiler compiles without -dGDB, but doesn't work yet
+    + -vh for Hint
+
+  Revision 1.22  1998/03/02 01:49:00  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.21  1998/02/28 14:43:47  florian
+    * final implemenation of win32 imports
+    * extended tai_align to allow 8 and 16 byte aligns
+
+  Revision 1.20  1998/02/19 00:11:07  peter
+    * fixed -g to work again
+    * fixed some typos with the scriptobject
+
+  Revision 1.19  1998/02/13 10:35:23  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.18  1998/02/12 17:19:19  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.17  1998/02/12 11:50:25  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.16  1998/02/11 21:56:36  florian
+    * bugfixes: bug0093, bug0053, bug0088, bug0087, bug0089
+
+  Revision 1.15  1998/02/06 10:34:25  florian
+    * bug0082 and bug0084 fixed
+
+  Revision 1.14  1998/02/02 11:56:49  pierre
+    * better line info for var statement
+
+  Revision 1.13  1998/01/30 21:25:31  carl
+    * bugfix #86 + checking of all other macros for crashes, fixed typeof
+       partly among others.
+
+  Revision 1.12  1998/01/23 17:12:19  pierre
+    * added some improvements for as and ld :
+      - doserror and dosexitcode treated separately
+      - PATH searched if doserror=2
+    + start of long and ansi string (far from complete)
+      in conditionnal UseLongString and UseAnsiString
+    * options.pas cleaned (some variables shifted to globals)gl
+
+  Revision 1.11  1998/01/21 21:25:46  florian
+    * small problem with variante records fixed:
+       case a : (x,y,z) of
+       ...
+      is now allowed
+
+  Revision 1.10  1998/01/13 23:11:13  florian
+    + class methods
+
+  Revision 1.9  1998/01/12 13:03:31  florian
+    + parsing of class methods implemented
+
+  Revision 1.8  1998/01/11 10:54:23  florian
+    + generic library support
+
+  Revision 1.7  1998/01/09 23:08:32  florian
+    + C++/Delphi styled //-comments
+    * some bugs in Delphi object model fixed
+    + override directive
+
+  Revision 1.6  1998/01/09 18:01:16  florian
+    * VIRTUAL isn't anymore a common keyword
+    + DYNAMIC is equal to VIRTUAL
+
+  Revision 1.5  1998/01/09 16:08:23  florian
+    * abstract methods call now abstracterrorproc if they are called
+      a class with an abstract method can be create with a class reference else
+      the compiler forbides this
+
+  Revision 1.4  1998/01/09 13:39:55  florian
+    * public, protected and private aren't anymore key words
+    + published is equal to public
+
+  Revision 1.3  1998/01/09 13:18:12  florian
+    + "forward" class declarations   (type tclass = class; )
+
+  Revision 1.2  1998/01/09 09:09:58  michael
+  + Initial implementation, second try
+
+}

compiler/pexports.pas

@@ -0,0 +1,161 @@
+{
+    $Id$
+    Copyright (c) 1998 by Florian Klaempfl
+
+    This unit handles the exports parsing
+
+    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 pexports;
+
+  interface
+
+    { reads an exports statement in a library }
+    procedure read_exports;
+
+  implementation
+
+    uses
+       cobjects,globals,scanner,symtable,pbase,verbose;
+
+    const
+       { export options }
+       eo_resident = $1;
+
+    type
+       pexportsitem = ^texportsitem;
+
+       texportsitem = object(tlinkedlist_item)
+          sym : psym;
+          index : longint;
+          name : pstring;
+          options : word;
+          constructor init;
+       end;
+
+    var
+       exportslist : tlinkedlist;
+
+    constructor texportsitem.init;
+
+      begin
+         sym:=nil;
+         index:=-1;
+         name:=nil;
+         options:=0;
+      end;
+
+    procedure read_exports;
+
+      var
+         hp : pexportsitem;
+         code : word;
+
+      begin
+         hp:=new(pexportsitem,init);
+         consume(_EXPORTS);
+         while true do
+           begin
+              if token=ID then
+                begin
+                   getsym(pattern,true);
+                   if srsym^.typ=unitsym then
+                     begin
+                        consume(ID);
+                        consume(POINT);
+                        getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
+                     end;
+                   consume(ID);
+                   if assigned(srsym) then
+                     begin
+                        hp^.sym:=srsym;
+                        if (srsym^.typ<>procsym) or
+                          ((pprocdef(pprocsym(srsym)^.definition)^.options and poexports)=0) then
+                          Message(parser_e_illegal_symbol_exported);
+                        if (token=ID) and (pattern='INDEX') then
+                          begin
+                             consume(ID);
+                             val(pattern,hp^.index,code);
+                             consume(INTCONST);
+                          end;
+                        if (token=ID) and (pattern='NAME') then
+                          begin
+                             consume(ID);
+                             hp^.name:=stringdup(pattern);
+                             consume(ID);
+                          end;
+                        if (token=ID) and (pattern='RESIDENT') then
+                          begin
+                             consume(ID);
+                             hp^.options:=hp^.options or eo_resident;
+                          end;
+                     end;
+                end
+              else
+                consume(ID);
+              if token=COMMA then
+                consume(COMMA)
+              else
+                break;
+           end;
+         consume(SEMICOLON);
+      end;
+
+begin
+   { a library is a root of sources, e.g. it can't be used
+     twice in one compiler run }
+   exportslist.init;
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.7  1998/03/10 01:17:24  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.6  1998/03/06 00:52:42  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.5  1998/03/02 01:49:01  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.4  1998/02/13 10:35:24  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.3  1998/01/12 13:02:41  florian
+    + items of exports are now seperated by ,
+
+  Revision 1.2  1998/01/12 12:11:35  florian
+    + unit qualifier is now allowed to specify exported symbols
+    + exports starts now a list of symbols to export
+
+  Revision 1.1  1998/01/11 10:58:07  florian
+    + pexports in lowercase commited
+
+  Revision 1.1  1998/01/11 10:54:19  florian
+    + generic library support
+
+}

compiler/pexpr.pas

@@ -0,0 +1,1686 @@
+{
+    $Id$
+    Copyright (c) 1998 by Florian Klaempfl
+
+    Does parsing of expression for Free Pascal
+
+    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 pexpr;
+
+  interface
+
+    uses symtable,tree;
+
+    { reads a whole expression }
+    function expr : ptree;
+
+    { reads a single factor }
+    function factor(getaddr : boolean) : ptree;
+
+    { the ID token has to be consumed before calling this function }
+    procedure do_member_read(const sym : psym;var p1 : ptree;
+      var pd : pdef;var again : boolean);
+
+    function get_intconst:longint;
+
+    function get_stringconst:string;
+
+  implementation
+
+    uses
+       cobjects,globals,scanner,aasm,pass_1,systems,
+       hcodegen,types,verbose
+       { parser specific stuff }
+       ,pbase,pdecl
+       { processor specific stuff }
+{$ifdef i386}
+       ,i386
+{$endif}
+{$ifdef m68k}
+       ,m68k
+{$endif}
+       ;
+
+    function parse_paras(_colon,in_prop_paras : boolean) : ptree;
+
+      var
+         p1,p2 : ptree;
+         end_of_paras : ttoken;
+
+      begin
+         if in_prop_paras  then
+           end_of_paras:=RECKKLAMMER
+         else
+           end_of_paras:=RKLAMMER;
+         if token=end_of_paras then
+           begin
+              parse_paras:=nil;
+              exit;
+           end;
+         p2:=nil;
+         inc(parsing_para_level);
+         while true do
+           begin
+              p1:=expr;
+              p2:=gencallparanode(p1,p2);
+
+              { it's for the str(l:5,s); }
+              if _colon and (token=COLON) then
+                begin
+                   consume(COLON);
+                   p1:=expr;
+                   p2:=gencallparanode(p1,p2);
+                   p2^.is_colon_para:=true;
+                   if token=COLON then
+                     begin
+                        consume(COLON);
+                        p1:=expr;
+                        p2:=gencallparanode(p1,p2);
+                        p2^.is_colon_para:=true;
+                     end
+                end;
+              if token=COMMA then
+                consume(COMMA)
+              else
+                break;
+           end;
+         dec(parsing_para_level);
+         parse_paras:=p2;
+      end;
+
+    function statement_syssym(l : longint;var pd : pdef) : ptree;
+{   const   regnames:array[R_EAX..R_EDI] of string[3]=
+             ('EAX','ECX','EDX','EBX','','','ESI','EDI'); }
+
+      var
+         p1,p2 : ptree;
+         paras : ptree;
+         prev_in_args : boolean;
+         Store_valid : boolean;
+
+      begin
+         prev_in_args:=in_args;
+         Store_valid:=Must_be_valid;
+         case l of
+            in_ord_x :
+              begin
+                 consume(LKLAMMER);
+                 in_args:=true;
+                 Must_be_valid:=true;
+                 p1:=expr;
+                 consume(RKLAMMER);
+                 do_firstpass(p1);
+                 p1:=geninlinenode(in_ord_x,p1);
+                 do_firstpass(p1);
+                 statement_syssym := p1;
+                 pd:=p1^.resulttype;
+              end;
+            in_typeof_x : begin
+                             consume(LKLAMMER);
+                             in_args:=true;
+                             p1:=expr;
+                             consume(RKLAMMER);
+                             pd:=voidpointerdef;
+                             if p1^.treetype=typen then
+                               begin
+                                  if (p1^.resulttype=nil) then
+                                    begin
+                                       Message(sym_e_type_mismatch);
+                                       statement_syssym:=genzeronode(errorn);
+                                    end
+                                  else
+                                  if p1^.resulttype^.deftype=objectdef then
+                                    statement_syssym:=geninlinenode(in_typeof_x,p1)
+                                  else
+                                    begin
+                                       Message(sym_e_type_mismatch);
+                                       statement_syssym:=genzeronode(errorn);
+                                    end;
+                               end
+                             else
+                               begin
+                                  Must_be_valid:=false;
+                                  do_firstpass(p1);
+                                  if (p1^.resulttype=nil) then
+                                    begin
+                                       Message(sym_e_type_mismatch);
+                                       statement_syssym:=genzeronode(errorn)
+                                    end
+                                  else
+                                  if p1^.resulttype^.deftype=objectdef then
+                                    statement_syssym:=geninlinenode(in_typeof_x,p1)
+                                  else
+                                    begin
+                                       Message(sym_e_type_mismatch);
+                                       statement_syssym:=genzeronode(errorn)
+                                    end;
+                               end;
+                          end;
+            in_sizeof_x : begin
+                             consume(LKLAMMER);
+                             in_args:=true;
+                             p1:=expr;
+                             consume(RKLAMMER);
+                             pd:=s32bitdef;
+                             if p1^.treetype=typen then
+                               begin
+                                  statement_syssym:=genordinalconstnode(
+                                    p1^.resulttype^.size,pd);
+                                  { p1 not needed !}
+                                  disposetree(p1);
+                               end
+                             else
+                               begin
+                                  Must_be_valid:=false;
+                                  do_firstpass(p1);
+                                  if p1^.resulttype^.deftype<>objectdef then
+                                    begin
+                                       statement_syssym:=genordinalconstnode(
+                                         p1^.resulttype^.size,pd);
+                                       { p1 not needed !}
+                                       disposetree(p1);
+                                    end
+                                  else
+                                    begin
+                                       statement_syssym:=geninlinenode(in_sizeof_x,p1);
+                                    end;
+                               end;
+                          end;
+            in_assigned_x : begin
+                               consume(LKLAMMER);
+                               in_args:=true;
+                               p1:=expr;
+                               Must_be_valid:=true;
+                               do_firstpass(p1);
+                               case p1^.resulttype^.deftype of
+                                 pointerdef,procvardef,
+                                 classrefdef:
+                                   ;
+                                 objectdef:
+                                   if not(pobjectdef(p1^.resulttype)^.isclass) then
+                                     Message(parser_e_illegal_parameter_list);
+                                 else Message(parser_e_illegal_parameter_list);
+                               end;
+                               p2:=gencallparanode(p1,nil);
+                               p2:=geninlinenode(in_assigned_x,p2);
+                               consume(RKLAMMER);
+                               pd:=booldef;
+                               statement_syssym:=p2;
+                            end;
+            in_ofs_x : begin
+                          consume(LKLAMMER);
+                          in_args:=true;
+                          p1:=expr;
+                          p1:=gensinglenode(addrn,p1);
+                          Must_be_valid:=false;
+                          do_firstpass(p1);
+                        { Ofs() returns a longint, not a pointer }
+                          p1^.resulttype:=u32bitdef;
+                          pd:=p1^.resulttype;
+                          consume(RKLAMMER);
+                          statement_syssym:=p1;
+                       end;
+            in_seg_x : begin
+                          consume(LKLAMMER);
+                          in_args:=true;
+                          p1:=expr;
+                          do_firstpass(p1);
+                          if p1^.location.loc<>LOC_REFERENCE then
+                            Message(cg_e_illegal_expression);
+                          p1:=genordinalconstnode(0,s32bitdef);
+                          Must_be_valid:=false;
+                          pd:=s32bitdef;
+                          consume(RKLAMMER);
+                          statement_syssym:=p1;
+                       end;
+            in_high_x,
+            in_low_x : begin
+                          consume(LKLAMMER);
+                          in_args:=true;
+                          p1:=expr;
+                          do_firstpass(p1);
+                          Must_be_valid:=false;
+                          p2:=geninlinenode(l,p1);
+                          consume(RKLAMMER);
+                          pd:=s32bitdef;
+                          statement_syssym:=p2;
+                       end;
+            in_succ_x,
+            in_pred_x : begin
+                          consume(LKLAMMER);
+                          in_args:=true;
+                          p1:=expr;
+                          do_firstpass(p1);
+                          Must_be_valid:=false;
+                          p2:=geninlinenode(l,p1);
+                          consume(RKLAMMER);
+                          pd:=p1^.resulttype;
+                          statement_syssym:=p2;
+                       end;
+            in_inc_x,
+            in_dec_x : begin
+                          consume(LKLAMMER);
+                          in_args:=true;
+                          p1:=expr;
+                          p2:=gencallparanode(p1,nil);
+                          Must_be_valid:=false;
+                          if token=COMMA then
+                            begin
+                               consume(COMMA);
+                               p1:=expr;
+                               p2:=gencallparanode(p1,p2);
+                            end;
+                          statement_syssym:=geninlinenode(l,p2);
+                          consume(RKLAMMER);
+                          pd:=voiddef;
+                       end;
+            in_concat_x : begin
+                             consume(LKLAMMER);
+                             in_args:=true;
+                             p2:=nil;
+                             while true do
+                               begin
+                                  p1:=expr;
+                                  Must_be_valid:=true;
+                                  do_firstpass(p1);
+                                  if not((p1^.resulttype^.deftype=stringdef) or
+                                         ((p1^.resulttype^.deftype=orddef) and
+                                          (porddef(p1^.resulttype)^.typ=uchar)
+                                         )
+                                    ) then Message(parser_e_illegal_parameter_list);
+                                  if p2<>nil then
+                                    p2:=gennode(addn,p2,p1)
+                                  else p2:=p1;
+                                  if token=COMMA then
+                                    consume(COMMA)
+                                  else break;
+                               end;
+                             consume(RKLAMMER);
+                             pd:=cstringdef;
+                             statement_syssym:=p2;
+                          end;
+            in_read_x,
+            in_readln_x : begin
+                             if token=LKLAMMER then
+                               begin
+                                  consume(LKLAMMER);
+                                  in_args:=true;
+                                  Must_be_valid:=false;
+                                  paras:=parse_paras(false,false);
+                                  consume(RKLAMMER);
+                               end
+                             else
+                               paras:=nil;
+                             pd:=voiddef;
+                             p1:=geninlinenode(l,paras);
+                             do_firstpass(p1);
+                             statement_syssym := p1;
+                          end;
+            in_write_x,
+            in_writeln_x : begin
+                             if token=LKLAMMER then
+                               begin
+                                  consume(LKLAMMER);
+                                  in_args:=true;
+                                  Must_be_valid:=true;
+                                  paras:=parse_paras(true,false);
+                                  consume(RKLAMMER);
+                               end
+                             else
+                               paras:=nil;
+                             pd:=voiddef;
+                             p1 := geninlinenode(l,paras);
+                             do_firstpass(p1);
+                             statement_syssym := p1;
+                          end;
+            in_str_x_string : begin
+                                 consume(LKLAMMER);
+                                 in_args:=true;
+                                 paras:=parse_paras(true,false);
+                                 consume(RKLAMMER);
+                                 p1 := geninlinenode(l,paras);
+                                 do_firstpass(p1);
+                                 statement_syssym := p1;
+                                 pd:=voiddef;
+                              end;
+            {in_val_x :        begin
+                                 consume(LKLAMMER);
+                                 paras:=parse_paras(false);
+                                 consume(RKLAMMER);
+                                 p1 := geninlinenode(l,paras);
+                                 do_firstpass(p1);
+                                 statement_syssym := p1;
+                                 pd:=voiddef;
+                              end;    }
+            else internalerror(15);
+         end;
+         in_args:=prev_in_args;
+         Must_be_valid:=Store_valid;
+      end;
+
+    { reads the parameter for a subroutine call }
+    procedure do_proc_call(getaddr : boolean;var again : boolean;var p1:Ptree;var pd:Pdef);
+
+      var
+         prev_in_args : boolean;
+         prevafterassn : boolean;
+
+      begin
+         prev_in_args:=in_args;
+         prevafterassn:=afterassignment;
+         afterassignment:=false;
+         { want we only determine the address of }
+         { a subroutine                          }
+         if not(getaddr) then
+           begin
+              if token=LKLAMMER then
+                begin
+                   consume(LKLAMMER);
+                   in_args:=true;
+                   p1^.left:=parse_paras(false,false);
+                   consume(RKLAMMER);
+                end
+              else p1^.left:=nil;
+
+              { do firstpass because we need the  }
+              { result type                       }
+              do_firstpass(p1);
+           end
+         else
+           begin
+              { address operator @: }
+              p1^.left:=nil;
+              { forget pd }
+              pd:=nil;
+              { no postfix operators }
+              again:=false;
+           end;
+         pd:=p1^.resulttype;
+         in_args:=prev_in_args;
+         afterassignment:=prevafterassn;
+      end;
+
+    { the ID token has to be consumed before calling this function }
+    procedure do_member_read(const sym : psym;var p1 : ptree;
+      var pd : pdef;var again : boolean);
+
+      var
+         static_name : string;
+         paras : ptree;
+         oldafterassignment,isclassref : boolean;
+         p2 : ptree;
+
+      begin
+         if sym=nil then
+           begin
+              Message(sym_e_id_no_member);
+              disposetree(p1);
+              p1:=genzeronode(errorn);
+              { try to clean up }
+              pd:=generrordef;
+              again:=false;
+           end
+         else
+           begin
+              isclassref:=pd^.deftype=classrefdef;
+              { we assume, that only procsyms and varsyms are in an object }
+              { symbol table, for classes, properties are allowed          }
+              case sym^.typ of
+                 procsym:
+                   begin
+                      p1:=genmethodcallnode(pprocsym(sym),srsymtable,p1);
+                      do_proc_call(false,again,p1,pd);
+                      { now we know the real method e.g. we can check for }
+                      { a class method                                    }
+                      if isclassref and ((p1^.procdefinition^.options and (poclassmethod or poconstructor))=0) then
+                        Message(parser_e_only_class_methods_via_class_ref);
+                   end;
+                 varsym:
+                   begin
+                      if isclassref then
+                        Message(parser_e_only_class_methods_via_class_ref);
+                      if (sym^.properties and sp_static)<>0 then
+                        begin
+                           static_name:=lowercase(srsymtable^.name^)+'_'+sym^.name;
+                           getsym(static_name,true);
+                           disposetree(p1);
+                           p1:=genloadnode(pvarsym(srsym),srsymtable);
+                        end
+                      else
+                        p1:=gensubscriptnode(pvarsym(sym),p1);
+                      pd:=pvarsym(sym)^.definition;
+                   end;
+                 propertysym:
+                   begin
+                      if isclassref then
+                        Message(parser_e_only_class_methods_via_class_ref);
+                      paras:=nil;
+                      { property parameters? }
+                      if token=LECKKLAMMER then
+                        begin
+                           consume(LECKKLAMMER);
+                           paras:=parse_paras(false,true);
+                           consume(RECKKLAMMER);
+                        end;
+                      { indexed property }
+                      if (ppropertysym(sym)^.options and ppo_indexed)<>0 then
+                        begin
+                           p2:=genordinalconstnode(ppropertysym(sym)^.index,s32bitdef);
+                           paras:=gencallparanode(p2,paras);
+                        end;
+                      if not(afterassignment) and not(in_args) then
+                        begin
+                           { write property: }
+                           { no result }
+                           pd:=voiddef;
+                           if assigned(ppropertysym(sym)^.writeaccesssym) then
+                             begin
+                                if ppropertysym(sym)^.writeaccesssym^.typ=procsym then
+                                  begin
+                                     { generate the method call }
+                                     p1:=genmethodcallnode(pprocsym(
+                                       ppropertysym(sym)^.writeaccesssym),
+                                       ppropertysym(sym)^.writeaccesssym^.owner,p1);
+                                     p1^.left:=paras;
+                                     { to be on the save side }
+                                     oldafterassignment:=afterassignment;
+                                     consume(ASSIGNMENT);
+                                     { read the expression }
+                                     afterassignment:=true;
+                                     p2:=expr;
+                                     p1^.left:=gencallparanode(p2,p1^.left);
+                                     afterassignment:=oldafterassignment;
+                                  end
+                                else if ppropertysym(sym)^.writeaccesssym^.typ=varsym then
+                                  begin
+                                     if assigned(paras) then
+                                       message(parser_e_no_paras_allowed);
+                                     p1:=gensubscriptnode(pvarsym(
+                                       ppropertysym(sym)^.readaccesssym),p1);
+                                     { to be on the save side }
+                                     oldafterassignment:=afterassignment;
+                                     consume(ASSIGNMENT);
+                                     { read the expression }
+                                     afterassignment:=true;
+                                     p2:=expr;
+                                     p1:=gennode(assignn,p1,p2);
+                                     afterassignment:=oldafterassignment;
+                                  end
+                                else
+                                  begin
+                                     p1:=genzeronode(errorn);
+                                     Message(parser_e_no_procedure_to_access_property);
+                                  end;
+                             end
+                           else
+                             begin
+                                p1:=genzeronode(errorn);
+                                Message(parser_e_no_procedure_to_access_property);
+                             end;
+                        end
+                      else
+                        begin
+                           { read property: }
+                           pd:=ppropertysym(sym)^.proptype;
+                           if assigned(ppropertysym(sym)^.readaccesssym) then
+                             begin
+                                if ppropertysym(sym)^.readaccesssym^.typ=varsym then
+                                  begin
+                                     if assigned(paras) then
+                                       message(parser_e_no_paras_allowed);
+                                     p1:=gensubscriptnode(pvarsym(
+                                       ppropertysym(sym)^.readaccesssym),p1);
+                                     pd:=pvarsym(sym)^.definition;
+                                  end
+                                else if ppropertysym(sym)^.readaccesssym^.typ=procsym then
+                                  begin
+                                     { generate the method call }
+                                     p1:=genmethodcallnode(pprocsym(
+                                       ppropertysym(sym)^.readaccesssym),
+                                       ppropertysym(sym)^.readaccesssym^.owner,p1);
+                                     { insert paras }
+                                     p1^.left:=paras;
+                                     { if we should be delphi compatible }
+                                     { then force type conversion      }
+                                     if cs_delphi2_compatible in aktswitches then
+                                       p1:=gentypeconvnode(p1,pd);
+                                  end
+                                else
+                                  begin
+                                     p1:=genzeronode(errorn);
+                                     Message(sym_e_type_mismatch);
+                                  end;
+                             end
+                           else
+                             begin
+                                { error, no function to read property }
+                                p1:=genzeronode(errorn);
+                                Message(parser_e_no_procedure_to_access_property);
+                             end;
+                        end;
+                   end;
+                 else internalerror(16);
+              end;
+           end;
+      end;
+
+    function factor(getaddr : boolean) : ptree;
+
+      var
+         l : longint;
+         p1,p2,p3 : ptree;
+         code : word;
+         pd,pd2 : pdef;
+         unit_specific, again : boolean;
+         static_name : string;
+         sym : pvarsym;
+         classh : pobjectdef;
+         d : bestreal;
+         constset : pconstset;
+
+
+      { p1 and p2 must contain valid values }
+      procedure postfixoperators;
+
+        begin
+           while again do
+             begin
+                case token of
+                   CARET:
+                     begin
+                        consume(CARET);
+                        if pd^.deftype<>pointerdef then
+                          begin
+                             { ^ as binary operator is a problem!!!! (FK) }
+                             again:=false;
+                             Message(cg_e_invalid_qualifier);
+                             disposetree(p1);
+                             p1:=genzeronode(errorn);
+                          end
+                        else
+                          begin
+                             p1:=gensinglenode(derefn,p1);
+                             pd:=ppointerdef(pd)^.definition;
+                          end;
+                     end;
+                   LECKKLAMMER : begin
+                                    consume(LECKKLAMMER);
+                                    repeat
+                                      if (pd^.deftype<>arraydef) and
+                                         (pd^.deftype<>stringdef) and
+                                         (pd^.deftype<>pointerdef) then
+                                        begin
+                                           Message(cg_e_invalid_qualifier);
+                                           disposetree(p1);
+                                           p1:=genzeronode(errorn);
+                                        end
+                                      else if (pd^.deftype=pointerdef) then
+                                        begin
+                                           p2:=expr;
+                                           p1:=gennode(vecn,p1,p2);
+                                           pd:=ppointerdef(pd)^.definition;
+                                        end
+                                      else
+                                        begin
+                                           p2:=expr;
+                                         { support SEG:OFS for go32v2 Mem[] }
+                                           if (target_info.target=target_GO32V2) and
+                                              assigned(p1^.symtableentry) and
+                                              assigned(p1^.symtableentry^.owner^.name) and
+                                              (p1^.symtableentry^.owner^.name^='SYSTEM') and
+                                              ((p1^.symtableentry^.name='MEM') or
+                                               (p1^.symtableentry^.name='MEMW') or
+                                               (p1^.symtableentry^.name='MEML')) then
+                                             begin
+                                               if (token=COLON) then
+                                                begin
+                                                  consume(COLON);
+                                                  p3:=gennode(muln,genordinalconstnode($10,s32bitdef),p2);
+                                                  p2:=expr;
+                                                  p2:=gennode(addn,p2,p3);
+                                                  p1:=gennode(vecn,p1,p2);
+                                                  p1^.memseg:=true;
+                                                  p1^.memindex:=true;
+                                                end
+                                               else
+                                                begin
+                                                  p1:=gennode(vecn,p1,p2);
+                                                  p1^.memindex:=true;
+                                                end;
+                                             end
+                                           else
+                                             p1:=gennode(vecn,p1,p2);
+                                           if pd^.deftype=stringdef then
+                                             pd:=cchardef
+                                           else
+                                             pd:=parraydef(pd)^.definition;
+                                        end;
+                                      if token=COMMA then consume(COMMA)
+                                        else break;
+                                    until false;
+                                    consume(RECKKLAMMER);
+                                 end;
+                   POINT       : begin
+                                    consume(POINT);
+                                    case pd^.deftype of
+                                       recorddef:
+                                             begin
+                                                sym:=pvarsym(precdef(pd)^.symtable^.search(pattern));
+                                                consume(ID);
+                                                if sym=nil then
+                                                  begin
+                                                     Message(sym_e_illegal_field);
+                                                     disposetree(p1);
+                                                     p1:=genzeronode(errorn);
+                                                  end
+                                                else
+                                                  begin
+                                                     p1:=gensubscriptnode(sym,p1);
+                                                     pd:=sym^.definition;
+                                                  end;
+                                             end;
+                                       classrefdef:
+                                         begin
+                                            classh:=pobjectdef(pclassrefdef(pd)^.definition);
+                                            sym:=nil;
+                                            while assigned(classh) do
+                                              begin
+                                                 sym:=pvarsym(classh^.publicsyms^.search(pattern));
+                                                 srsymtable:=classh^.publicsyms;
+                                                 if assigned(sym) then
+                                                   break;
+                                                 classh:=classh^.childof;
+                                              end;
+                                            consume(ID);
+                                            do_member_read(sym,p1,pd,again);
+                                         end;
+                                       objectdef:
+                                             begin
+                                                classh:=pobjectdef(pd);
+                                                sym:=nil;
+                                                while assigned(classh) do
+                                                  begin
+                                                     sym:=pvarsym(classh^.publicsyms^.search(pattern));
+                                                     srsymtable:=classh^.publicsyms;
+                                                     if assigned(sym) then
+                                                       break;
+                                                     classh:=classh^.childof;
+                                                  end;
+                                                consume(ID);
+                                                do_member_read(sym,p1,pd,again);
+                                             end;
+                                       pointerdef:
+                                          begin
+                                             if ppointerdef(pd)^.definition^.deftype
+                                                in [recorddef,objectdef,classrefdef] then
+                                                begin
+                                                   Message(cg_e_invalid_qualifier);
+                                                   { exterror:=strpnew(' may be pointer deref ^ is missing');
+                                                   error(invalid_qualifizier); }
+                                                   Comment(V_hint,' may be pointer deref ^ is missing');
+                                                end
+                                             else
+                                                Message(cg_e_invalid_qualifier);
+                                          end
+                                          else
+                                             begin
+                                                Message(cg_e_invalid_qualifier);
+                                                disposetree(p1);
+                                                p1:=genzeronode(errorn);
+                                             end;
+                                    end;
+                                 end;
+                   else
+                     begin
+                        { is this a procedure variable ? }
+                        if assigned(pd) then
+                        begin
+                          if  (pd^.deftype=procvardef) then
+                          begin
+                             if getprocvar then
+                               again:=false
+                             else
+                             if (token=LKLAMMER) or
+                                ((pprocvardef(pd)^.para1=nil) and
+                                (token<>ASSIGNMENT) and (not in_args)) then
+                               begin
+                                  { do this in a strange way  }
+                                  { it's not a clean solution }
+                                  p2:=p1;
+                                  p1:=gencallnode(nil,
+                                    nil);
+                                  p1^.right:=p2;
+                                  p1^.unit_specific:=unit_specific;
+                                  if token=LKLAMMER then
+                                    begin
+                                       consume(LKLAMMER);
+                                       p1^.left:=parse_paras(false,false);
+                                       consume(RKLAMMER);
+                                    end;
+                                  pd:=pprocvardef(pd)^.retdef;
+                                  p1^.resulttype:=pd;
+                               end
+                             else again:=false;
+                             p1^.resulttype:=pd;
+                          end
+                          else again:=false;
+                        end
+                        else again:=false;
+                     end;
+                end;
+           end;
+      end;
+
+    procedure do_set(p : pconstset;pos : longint);
+
+      var
+         l : longint;
+
+      begin
+         if (pos>255) or
+            (pos<0) then
+           Message(parser_e_illegal_set_expr);
+         l:=pos div 8;
+         { do we allow the same twice }
+         if (p^[l] and (1 shl (pos mod 8)))<>0 then
+           Message(parser_e_illegal_set_expr);
+         p^[l]:=p^[l] or (1 shl (pos mod 8));
+      end;
+
+      var
+         possible_error : boolean;
+         storesymtablestack : psymtable;
+         actprocsym : pprocsym;
+
+      begin
+         case token of
+            ID:
+          begin
+                 { allow post fix operators }
+                 again:=true;
+                 if (cs_delphi2_compatible in aktswitches) and
+                    (pattern='RESULT') and
+                   assigned(aktprocsym) and
+                   (procinfo.retdef<>pdef(voiddef)) then
+                   begin
+                      consume(ID);
+                      p1:=genzeronode(funcretn);
+                      pd:=procinfo.retdef;
+{$ifdef TEST_FUNCRET}
+                      p1^.funcretprocinfo:=pointer(@procinfo);
+                      p1^.retdef:=pd;
+{$endif TEST_FUNCRET}
+                   end
+                 else
+                   begin
+                      getsym(pattern,true);
+                      consume(ID);
+                      { is this an access to a function result ? }
+                       if assigned(aktprocsym) and
+                        ((srsym^.name=aktprocsym^.name) or
+                        ((pvarsym(srsym)=opsym) and
+                        ((pprocdef(aktprocsym^.definition)^.options and pooperator)<>0))) and
+                        (procinfo.retdef<>pdef(voiddef)) and
+                        (token<>LKLAMMER) and
+                        (not ((cs_tp_compatible in aktswitches) and
+                        (afterassignment or in_args))) then
+                        begin
+                           p1:=genzeronode(funcretn);
+                           pd:=procinfo.retdef;
+{$ifdef TEST_FUNCRET}
+                           p1^.funcretprocinfo:=pointer(@procinfo);
+                           p1^.retdef:=pd;
+{$endif TEST_FUNCRET}
+                        end
+                      else
+                        { else it's a normal symbol }
+                        begin
+                           if srsym^.typ=unitsym then
+                             begin
+                                consume(POINT);
+                                getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
+                                unit_specific:=true;
+                                consume(ID);
+                             end
+                           else
+                             unit_specific:=false;
+                           case srsym^.typ of
+                              absolutesym:
+                                begin
+                                   p1:=genloadnode(pvarsym(srsym),srsymtable);
+                                   pd:=pabsolutesym(srsym)^.definition;
+                                end;
+                              varsym:
+                                begin
+                                   { are we in a class method ? }
+                                   if (srsymtable^.symtabletype=objectsymtable) and
+                                     assigned(aktprocsym) and
+                                     ((aktprocsym^.definition^.options and poclassmethod)<>0) then
+                                     Message(parser_e_only_class_methods);
+
+                                     if (srsym^.properties and sp_static)<>0 then
+                                       begin
+                                          static_name:=lowercase(srsymtable^.name^)+'_'+srsym^.name;
+                                          getsym(static_name,true);
+                                       end;
+                                     p1:=genloadnode(pvarsym(srsym),srsymtable);
+                                     if pvarsym(srsym)^.is_valid=0 then
+                                       begin
+                                          p1^.is_first := true;
+                                          { set special between first loaded
+                                            until checked in firstpass }
+                                          pvarsym(srsym)^.is_valid:=2;
+                                       end;
+                                     pd:=pvarsym(srsym)^.definition;
+                                  end;
+                              typedconstsym:
+                                begin
+                                   p1:=gentypedconstloadnode(ptypedconstsym(srsym),srsymtable);
+                                   pd:=ptypedconstsym(srsym)^.definition;
+                                end;
+                              syssym:
+                                p1:=statement_syssym(psyssym(srsym)^.number,pd);
+                              typesym:
+                                begin
+                                   pd:=ptypesym(srsym)^.definition;
+                                   if token=LKLAMMER then
+                                     begin
+                                        consume(LKLAMMER);
+                                        p1:=expr;
+                                        consume(RKLAMMER);
+                                        p1:=gentypeconvnode(p1,pd);
+                                        p1^.explizit:=true;
+                                     end
+                                   else if (token=POINT) and
+                                     (pd^.deftype=objectdef) and
+                                     ((pobjectdef(pd)^.options and oois_class)=0) then
+                                     begin
+                                        consume(POINT);
+                                        if assigned(procinfo._class) then
+                                          begin
+                                             if procinfo._class^.isrelated(pobjectdef(pd)) then
+                                               begin
+                                                  p1:=genzeronode(typen);
+                                                  p1^.resulttype:=pd;
+                                                  srsymtable:=pobjectdef(pd)^.publicsyms;
+                                                  sym:=pvarsym(srsymtable^.search(pattern));
+                                                  consume(ID);
+                                                  do_member_read(sym,p1,pd,again);
+                                               end
+                                             else
+                                               begin
+                                                  Message(parser_e_no_super_class);
+                                                  pd:=generrordef;
+                                                  again:=false;
+                                               end;
+                                          end
+                                        else
+                                          begin
+                                             { allows @TObject.Load }
+                                             { also allows static methods and variables }
+
+                                              p1:=genzeronode(typen);
+                                              p1^.resulttype:=pd;
+                                              srsymtable:=pobjectdef(pd)^.publicsyms;
+                                              sym:=pvarsym(srsymtable^.search(pattern));
+                                              if not(getaddr) and
+                                                ((sym^.properties and sp_static)=0) then
+                                                Message(sym_e_only_static_in_static)
+                                              else
+                                                begin
+                                                   consume(ID);
+                                                   do_member_read(sym,p1,pd,again);
+                                                end;
+                                          end
+                                     end
+                                   else
+                                     begin
+                                        { class reference ? }
+                                        if (pd^.deftype=objectdef)
+                                          and ((pobjectdef(pd)^.options and oois_class)<>0) then
+                                          begin
+                                             p1:=genzeronode(typen);
+                                             p1^.resulttype:=pd;
+                                             pd:=new(pclassrefdef,init(pd));
+                                             p1:=gensinglenode(loadvmtn,p1);
+                                             p1^.resulttype:=pd;
+                                          end
+                                        else
+                                          begin
+                                             { generate a type node }
+                                             { (for typeof etc)     }
+                                             p1:=genzeronode(typen);
+                                             p1^.resulttype:=pd;
+                                             pd:=voiddef;
+                                          end;
+                                     end;
+                                end;
+                              enumsym:
+                                begin
+                                   p1:=genenumnode(penumsym(srsym));
+                                   pd:=p1^.resulttype;
+                                end;
+                              constsym:
+                                begin
+                                   case pconstsym(srsym)^.consttype of
+                                      constint:
+                                        p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef);
+                                      conststring:
+                                        p1:=genstringconstnode(pstring(pconstsym(srsym)^.value)^);
+                                      constchar:
+                                        p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
+                                      constreal:
+                                        p1:=genrealconstnode(pdouble(pconstsym(srsym)^.value)^);
+                                      constbool:
+                                        p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
+                                      constseta:
+                                        p1:=gensetconstruktnode(pconstset(pconstsym(srsym)^.value),
+                                          psetdef(pconstsym(srsym)^.definition));
+                                      constord:
+                                        p1:=genordinalconstnode(pconstsym(srsym)^.value,
+                                          pconstsym(srsym)^.definition);
+                                   end;
+                                   pd:=p1^.resulttype;
+                                end;
+                              procsym:
+                                begin
+                                   { are we in a class method ? }
+                                   possible_error:=(srsymtable^.symtabletype=objectsymtable) and
+                                     assigned(aktprocsym) and
+                                     ((aktprocsym^.definition^.options and poclassmethod)<>0);
+                                   p1:=gencallnode(pprocsym(srsym),srsymtable);
+                                   p1^.unit_specific:=unit_specific;
+                                   do_proc_call(getaddr,again,p1,pd);
+                                   if possible_error and
+                                     ((p1^.procdefinition^.options and poclassmethod)=0) then
+                                     Message(parser_e_only_class_methods);
+                                end;
+                              propertysym:
+                                begin
+                                   { access to property in a method }
+
+                                   { are we in a class method ? }
+                                   if (srsymtable^.symtabletype=objectsymtable) and
+                                     assigned(aktprocsym) and
+                                     ((aktprocsym^.definition^.options and poclassmethod)<>0) then
+                                     Message(parser_e_only_class_methods);
+                                   { !!!!! }
+                                end;
+                              errorsym:
+                                begin
+                                   p1:=genzeronode(errorn);
+                                   pd:=generrordef;
+                                   if token=LKLAMMER then
+                                     begin
+                                        consume(LKLAMMER);
+                                        parse_paras(false,false);
+                                        consume(RKLAMMER);
+                                     end;
+                                end;
+                              else
+                                begin
+                                   p1:=genzeronode(errorn);
+                                   pd:=generrordef;
+                                   Message(cg_e_illegal_expression);
+                                end;
+                           end;
+                        end;
+                   end;
+                 { handle post fix operators }
+                 postfixoperators;
+              end;
+            _NEW : begin
+                      consume(_NEW);
+                      consume(LKLAMMER);
+                      p1:=factor(false);
+                      if p1^.treetype<>typen then
+                        Message(sym_e_type_id_expected);
+                      pd:=p1^.resulttype;
+                      pd2:=pd;
+                      if (pd^.deftype<>pointerdef) or
+                         (ppointerdef(pd)^.definition^.deftype<>objectdef) then
+                        begin
+                           Message(parser_e_pointer_to_class_expected);
+
+                           { if an error occurs, read til the end of the new }
+                           { statement                                       }
+                           p1:=genzeronode(errorn);
+                           l:=1;
+                           while true do
+                             begin
+                                case token of
+                                   LKLAMMER : inc(l);
+                                   RKLAMMER : dec(l);
+                                end;
+                                consume(token);
+                                if l=0 then
+                                  break;
+                             end;
+                        end
+                      else
+                        begin
+                           disposetree(p1);
+                           p1:=genzeronode(hnewn);
+                           p1^.resulttype:=ppointerdef(pd)^.definition;
+                           consume(COMMA);
+
+                           afterassignment:=false;
+                           { determines the current object defintion }
+                           classh:=pobjectdef(ppointerdef(pd)^.definition);
+
+                           { check for an abstract class }
+                           if (classh^.options and oois_abstract)<>0 then
+                             Message(sym_e_no_instance_of_abstract_object);
+
+                           { search the constructor also in the symbol tables of }
+                           { the parents                                          }
+
+                           { no constructor found }
+                           sym:=nil;
+                           while assigned(classh) do
+                             begin
+                                sym:=pvarsym(classh^.publicsyms^.search(pattern));
+                                srsymtable:=classh^.publicsyms;
+                                if assigned(sym) then
+                                  break;
+                                classh:=classh^.childof;
+                             end;
+
+                           consume(ID);
+                           do_member_read(sym,p1,pd,again);
+                           if (p1^.treetype<>calln) or
+                              (assigned(p1^.procdefinition) and
+                               ((p1^.procdefinition^.options and poconstructor)=0)) then
+                             Message(parser_e_expr_have_to_be_constructor_call);
+                           p1:=gensinglenode(newn,p1);
+
+                           { set the resulttype }
+                           p1^.resulttype:=pd2;
+                           consume(RKLAMMER);
+                        end;
+                   end;
+            _SELF:
+              begin
+                 again:=true;
+                 consume(_SELF);
+                 if not assigned(procinfo._class) then
+                   begin
+                      p1:=genzeronode(errorn);
+                      pd:=generrordef;
+                      again:=false;
+                      Message(parser_e_self_not_in_method);
+                   end
+                 else
+                   begin
+                      if (aktprocsym^.definition^.options and poclassmethod)<>0 then
+                        begin
+                           { self in class methods is a class reference type }
+                           pd:=new(pclassrefdef,init(procinfo._class));
+                           p1:=genselfnode(pd);
+                           p1^.resulttype:=pd;
+                        end
+                      else
+                        begin
+                           p1:=genselfnode(procinfo._class);
+                           p1^.resulttype:=procinfo._class;
+                        end;
+                      pd:=p1^.resulttype;
+                      postfixoperators;
+                   end;
+              end;
+            _INHERITED : begin
+                            again:=true;
+                            consume(_INHERITED);
+                            if assigned(procinfo._class) then
+                              begin
+                                 classh:=procinfo._class^.childof;
+                                 while assigned(classh) do
+                                   begin
+                                      srsymtable:=pobjectdef(classh)^.publicsyms;
+                                      sym:=pvarsym(srsymtable^.search(pattern));
+                                      if assigned(sym) then
+                                        begin
+                                           p1:=genzeronode(typen);
+                                           p1^.resulttype:=classh;
+                                           pd:=p1^.resulttype;
+                                           consume(ID);
+                                           do_member_read(sym,p1,pd,again);
+                                           break;
+                                        end;
+                                      classh:=classh^.childof;
+                                   end;
+                                 if classh=nil then
+                                   begin
+                                      Message1(sym_e_id_no_member,pattern);
+                                      again:=false;
+                                      pd:=generrordef;
+                                      p1:=genzeronode(errorn);
+                                   end;
+                              end
+                            else
+                              Message(parser_e_generic_methods_only_in_methods);
+                            postfixoperators;
+                         end;
+            INTCONST : begin
+                          valint(pattern,l,code);
+                          if code<>0 then
+                            begin
+                               val(pattern,d,code);
+                               if code<>0 then
+                                 begin
+                                    Message(cg_e_invalid_integer);
+                                    l:=1;
+                                    consume(INTCONST);
+                                    p1:=genordinalconstnode(l,s32bitdef);
+                                 end
+                               else
+                                 begin
+                                    consume(INTCONST);
+                                    p1:=genrealconstnode(d);
+                                 end;
+                            end
+                          else
+                            begin
+                               consume(INTCONST);
+                               p1:=genordinalconstnode(l,s32bitdef);
+                            end;
+                       end;
+            REALNUMBER : begin
+                          val(pattern,d,code);
+                          if code<>0 then
+                            begin
+                               Message(parser_e_error_in_real);
+                               d:=1.0;
+                            end;
+                          consume(REALNUMBER);
+                          p1:=genrealconstnode(d);
+                        end;
+            { FILE and STRING can be also a type cast }
+            _STRING:
+              begin
+                 pd:=stringtype;
+                 consume(LKLAMMER);
+                 p1:=expr;
+                 consume(RKLAMMER);
+                 p1:=gentypeconvnode(p1,pd);
+                 p1^.explizit:=true;
+                 { handle postfix operators here e.g. string(a)[10] }
+                 again:=true;
+                 postfixoperators;
+              end;
+            _FILE:
+              begin
+                 pd:=cfiledef;
+                 consume(_FILE);
+                 consume(LKLAMMER);
+                 p1:=expr;
+                 consume(RKLAMMER);
+                 p1:=gentypeconvnode(p1,pd);
+                 p1^.explizit:=true;
+                 { handle postfix operators here e.g. string(a)[10] }
+                 again:=true;
+                 postfixoperators;
+              end;
+            CSTRING:
+              begin
+                 p1:=genstringconstnode(pattern);
+                 consume(CSTRING);
+              end;
+            CCHAR:
+              begin
+                 p1:=genordinalconstnode(ord(pattern[1]),cchardef);
+                 consume(CCHAR);
+              end;
+            KLAMMERAFFE : begin
+                             consume(KLAMMERAFFE);
+                             p1:=factor(true);
+                             p1:=gensinglenode(addrn,p1);
+                          end;
+            LKLAMMER : begin
+                          consume(LKLAMMER);
+                          p1:=expr;
+                          consume(RKLAMMER);
+                          { it's not a good solution        }
+                          { but (a+b)^ makes some problems  }
+                          case token of
+                             CARET,POINT,LECKKLAMMER:
+                               begin
+                                  { we need the resulttype  }
+                                  { of the expression in pd }
+                                  do_firstpass(p1);
+                                  pd:=p1^.resulttype;
+
+                                  again:=true;
+                                  postfixoperators;
+                               end;
+                          end;
+                       end;
+            LECKKLAMMER : begin
+                             consume(LECKKLAMMER);
+                             new(constset);
+                             for l:=0 to 31 do
+                               constset^[l]:=0;
+                             p2:=nil;
+                             pd:=nil;
+                             if token<>RECKKLAMMER then
+                               while true do
+                                 begin
+                                    p1:=expr;
+                                    do_firstpass(p1);
+                                    case p1^.treetype of
+                                       ordconstn : begin
+                                                      if pd=nil then
+                                                        pd:=p1^.resulttype;
+                                                     if not(is_equal(pd,p1^.resulttype)) then
+                                                       Message(parser_e_typeconflict_in_set)
+                                                     else
+                                                       do_set(constset,p1^.value);
+                                                     disposetree(p1);
+                                                   end;
+                                       rangen : begin
+                                                   if pd=nil then
+                                                     pd:=p1^.left^.resulttype;
+                                                   if not(is_equal(pd,p1^.left^.resulttype)) then
+                                                     Message(parser_e_typeconflict_in_set)
+                                                   else
+                                                     for l:=p1^.left^.value to p1^.right^.value do
+                                                       do_set(constset,l);
+                                                   disposetree(p1);
+                                                end;
+                                       stringconstn : begin
+                                                         if pd=nil then
+                                                           pd:=cchardef;
+                                                   if not(is_equal(pd,cchardef)) then
+                                                     Message(parser_e_typeconflict_in_set)
+                                                   else
+                                                     for l:=1 to length(pstring(p1^.values)^) do
+                                                       do_set(constset,ord(pstring(p1^.values)^[l]));
+                                                   disposetree(p1);
+                                                end;
+                                       else
+                                          begin
+                                             if pd=nil then
+                                               pd:=p1^.resulttype;
+                                             if not(is_equal(pd,p1^.resulttype)) then
+                                               Message(parser_e_typeconflict_in_set);
+                                             p2:=gennode(setelen,p1,p2);
+                                          end;
+                                    end;
+                                    if token=COMMA then
+                                      consume(COMMA)
+                                    else break;
+                                 end;
+                             consume(RECKKLAMMER);
+                             p1:=gensinglenode(setconstrn,p2);
+                             p1^.resulttype:=new(psetdef,init(pd,255));
+                             p1^.constset:=constset;
+                          end;
+            PLUS     : begin
+                          consume(PLUS);
+                          p1:=factor(false);
+                       end;
+            MINUS    : begin
+                          consume(MINUS);
+                          p1:=factor(false);
+                          p1:=gensinglenode(umminusn,p1);
+                       end;
+            _NOT     : begin
+                          consume(_NOT);
+                          p1:=factor(false);
+                          p1:=gensinglenode(notn,p1);
+                       end;
+            _TRUE    : begin
+                          consume(_TRUE);
+                          p1:=genordinalconstnode(1,booldef);
+                       end;
+            _FALSE    : begin
+                          consume(_FALSE);
+                          p1:=genordinalconstnode(0,booldef);
+                       end;
+            _NIL      : begin
+                           consume(_NIL);
+                           p1:=genzeronode(niln);
+                        end;
+            else
+              begin
+                 p1:=genzeronode(errorn);
+                 consume(token);
+                 Message(cg_e_illegal_expression);
+              end;
+         end;
+         factor:=p1;
+      end;
+
+    type    Toperator_precedence=(opcompare,opaddition,opmultiply);
+
+    const   tok2node:array[PLUS.._XOR] of Ttreetyp=
+                    (addn,subn,muln,slashn,equaln,gtn,ltn,gten,lten,
+                     isn,asn,inn,
+                     nothingn,caretn,nothingn,unequaln,nothingn,
+                     nothingn,nothingn,nothingn,nothingn,nothingn,
+                     nothingn,nothingn,nothingn,nothingn,nothingn,
+                     nothingn,nothingn,nothingn,nothingn,nothingn,
+                     nothingn,andn,nothingn,nothingn,nothingn,
+                     nothingn,nothingn,nothingn,nothingn,nothingn,
+                     nothingn,nothingn,divn,nothingn,nothingn,
+                     nothingn,nothingn,nothingn,nothingn,nothingn,
+                     nothingn,nothingn,nothingn,nothingn,nothingn,
+                     nothingn,nothingn,nothingn,nothingn,nothingn,
+                     modn,nothingn,nothingn,nothingn,nothingn,
+                     nothingn,nothingn,orn,
+                     nothingn,nothingn,nothingn,nothingn,nothingn,
+                     nothingn,nothingn,shln,shrn,
+                     nothingn,nothingn,nothingn,nothingn,nothingn,
+                     nothingn,nothingn,nothingn,nothingn,nothingn,
+                     nothingn,xorn);
+            operator_levels:array[Toperator_precedence] of set of Ttoken=
+                    ([LT,LTE,GT,GTE,EQUAL,UNEQUAL,_IN,_IS],
+                     [PLUS,MINUS,_OR,_XOR],
+                     [CARET,SYMDIF,STAR,SLASH,_DIV,_MOD,_AND,_SHL,_SHR,_AS]);
+
+    function sub_expr(pred_level:Toperator_precedence):Ptree;
+
+    {Reads a subexpression while the operators are of the current precedence
+     level, or any higher level. Replaces the old term, simpl_expr and
+     simpl2_expr.}
+
+    var p1,p2:Ptree;
+        oldt:Ttoken;
+
+    begin
+{        if pred_level=high(Toperator_precedence) then }
+         if pred_level=opmultiply then
+            p1:=factor(getprocvar)
+        else
+            p1:=sub_expr(succ(pred_level));
+        repeat
+            if token in operator_levels[pred_level] then
+                begin
+                    oldt:=token;
+                    consume(token);
+{                    if pred_level=high(Toperator_precedence) then }
+                    if pred_level=opmultiply then
+                        p2:=factor(getprocvar)
+                    else
+                        p2:=sub_expr(succ(pred_level));
+                    p1:=gennode(tok2node[oldt],p1,p2);
+                end
+            else
+                break;
+        until false;
+        sub_expr:=p1;
+    end;
+
+    function expr : ptree;
+
+      var
+         p1,p2 : ptree;
+         oldafterassignment : boolean;
+
+      begin
+         oldafterassignment:=afterassignment;
+         p1:=sub_expr(opcompare);
+         if token in [ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
+           afterassignment:=true;
+         case token of
+            POINTPOINT : begin
+                            consume(POINTPOINT);
+                            p2:=sub_expr(opcompare);
+                            p1:=gennode(rangen,p1,p2);
+                         end;
+            ASSIGNMENT : begin
+                            consume(ASSIGNMENT);
+                            { avoid a firstpass of a procedure if
+                            it must be assigned to a procvar }
+                            { should be recursive for a:=b:=c !!! }
+                            if (p1^.resulttype<>nil) and (p1^.resulttype^.deftype=procvardef) then
+                              getprocvar:=true;
+{$ifdef tp}
+                            p2:=expr;
+{$else}
+                            { FPC needs this to recognizes the call       }
+                            { because the function name can be used like  }
+                            { an simple variable                          }
+                            p2:=expr();
+{$endif}
+                            if getprocvar and (p2^.treetype=calln) then
+                              begin
+                                 p2^.treetype:=loadn;
+                                 p2^.resulttype:=pprocsym(p2^.symtableprocentry)^.definition;
+                                 p2^.symtableentry:=p2^.symtableprocentry;
+                              end;
+                            getprocvar:=false;
+                            p1:=gennode(assignn,p1,p2);
+                         end;
+                         { this is the code for C like assignements }
+                         { from an improvement of Peter Schaefer    }
+            _PLUSASN   : begin
+                            consume(_PLUSASN  );
+{$ifdef tp}
+                            p2:=expr;
+{$else}
+                            p2:=expr();
+{$endif}
+
+                            p1:=gennode(assignn,p1,gennode(addn,getcopy(p1),p2));
+                            { was first
+                              p1:=gennode(assignn,p1,gennode(addn,p1,p2));
+                              but disposetree assumes that we have a real
+                              *** tree *** }
+                         end;
+
+            _MINUSASN   : begin
+                            consume(_MINUSASN  );
+{$ifdef tp}
+                            p2:=expr;
+{$else}
+                            p2:=expr();
+{$endif}
+                            p1:=gennode(assignn,p1,gennode(subn,getcopy(p1),p2));
+                         end;
+            _STARASN   : begin
+                            consume(_STARASN  );
+{$ifdef tp}
+                            p2:=expr;
+{$else}
+                            p2:=expr();
+{$endif}
+                            p1:=gennode(assignn,p1,gennode(muln,getcopy(p1),p2));
+                         end;
+            _SLASHASN   : begin
+                            consume(_SLASHASN  );
+{$ifdef tp}
+                            p2:=expr;
+{$else}
+                            p2:=expr();
+{$endif}
+                            p1:=gennode(assignn,p1,gennode(slashn,getcopy(p1),p2));
+                         end;
+
+         end;
+         afterassignment:=oldafterassignment;
+         expr:=p1;
+      end;
+
+    function get_intconst:longint;
+
+    {Reads an expression, tries to evalute it and check if it is an integer
+     constant. Then the constant is returned.}
+
+    var p:Ptree;
+
+    begin
+        p:=expr;
+        do_firstpass(p);
+        if (p^.treetype<>ordconstn) and
+         (p^.resulttype^.deftype=orddef) and
+         not (Porddef(p^.resulttype)^.typ in
+         [uvoid,uchar,bool8bit]) then
+            Message(cg_e_illegal_expression)
+        else
+            get_intconst:=p^.value;
+        disposetree(p);
+    end;
+
+    function get_stringconst:string;
+
+    {Reads an expression, tries to evaluate it and checks if it is a string
+     constant. Then the constant is returned.}
+
+    var p:Ptree;
+
+    begin
+        get_stringconst:='';
+        p:=expr;
+        do_firstpass(p);
+        if p^.treetype<>stringconstn then
+            if (p^.treetype=ordconstn) and
+             (p^.resulttype^.deftype=orddef) and
+             (Porddef(p^.resulttype)^.typ=uchar) then
+                get_stringconst:=char(p^.value)
+            else
+                Message(cg_e_illegal_expression)
+        else
+            get_stringconst:=p^.values^;
+        disposetree(p);
+    end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:14  root
+  Initial revision
+
+  Revision 1.26  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.25  1998/03/21 23:59:39  florian
+    * indexed properties fixed
+    * ppu i/o of properties fixed
+    * field can be also used for write access
+    * overriding of properties
+
+  Revision 1.24  1998/03/16 22:42:21  florian
+    * some fixes of Peter applied:
+      ofs problem, profiler support
+
+  Revision 1.23  1998/03/11 11:23:57  florian
+    * bug0081 and bug0109 fixed
+
+  Revision 1.22  1998/03/10 16:27:42  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.21  1998/03/10 01:17:24  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.20  1998/03/06 00:52:44  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.19  1998/03/02 01:49:02  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.18  1998/03/01 22:46:18  florian
+    + some win95 linking stuff
+    * a couple of bugs fixed:
+      bug0055,bug0058,bug0059,bug0064,bug0072,bug0093,bug0095,bug0098
+
+  Revision 1.17  1998/02/27 21:24:06  florian
+    * dll support changed (dll name can be also a string contants)
+
+  Revision 1.16  1998/02/24 00:19:17  peter
+    * makefile works again (btw. linux does like any char after a \ )
+    * removed circular unit with assemble and files
+    * fixed a sigsegv in pexpr
+    * pmodule init unit/program is the almost the same, merged them
+
+  Revision 1.15  1998/02/13 10:35:24  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.14  1998/02/12 17:19:20  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.13  1998/02/12 11:50:26  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.12  1998/02/11 21:56:37  florian
+    * bugfixes: bug0093, bug0053, bug0088, bug0087, bug0089
+
+  Revision 1.11  1998/02/01 22:41:11  florian
+    * clean up
+    + system.assigned([class])
+    + system.assigned([class of xxxx])
+    * first fixes of as and is-operator
+
+  Revision 1.10  1998/02/01 15:04:15  florian
+    * better error recovering
+    * some clean up
+
+  Revision 1.9  1998/01/30 21:27:05  carl
+    * partial bugfix #88, #89 and typeof and other inline functions
+      (these bugs have a deeper nesting level, and therefore i only fixed
+       the parser crashes - there is also a tree crash).
+
+  Revision 1.8  1998/01/26 17:31:01  florian
+    * stupid bug with self in class methods fixed
+
+  Revision 1.7  1998/01/25 22:29:02  florian
+    * a lot bug fixes on the DOM
+
+  Revision 1.6  1998/01/23 10:46:41  florian
+    * small problems with FCL object model fixed, objpas?.inc is compilable
+
+  Revision 1.5  1998/01/16 22:34:42  michael
+  * Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
+    in this compiler :)
+
+  Revision 1.4  1998/01/16 18:03:15  florian
+    * small bug fixes, some stuff of delphi styled constructores added
+
+  Revision 1.3  1998/01/13 23:11:14  florian
+    + class methods
+
+  Revision 1.2  1998/01/09 09:09:59  michael
+  + Initial implementation, second try
+
+}

compiler/pmodules.pas

@@ -0,0 +1,1123 @@
+{
+    $Id$
+    Copyright (c) 1998 by Florian Klaempfl
+
+    Handles the parsing and loading of the modules (ppufiles)
+
+    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 pmodules;
+
+  interface
+
+    uses
+       dos,strings,
+       cobjects,globals,scanner,symtable,aasm,tree,pass_1,
+       types,hcodegen,files,verbose,systems,link,assemble
+{$ifdef GDB}
+       ,gdb
+{$endif GDB}
+       { parser specific stuff }
+       ,pbase,pdecl,pstatmnt,psub
+       { processor specific stuff }
+{$ifdef i386}
+       ,i386
+       ,cgai386
+       ,tgeni386
+       ,cgi386
+       ,aopt386
+{$endif}
+{$ifdef m68k}
+       ,m68k
+       ,cga68k
+       ,tgen68k
+       ,cg68k
+{$endif}
+       ;
+
+    function loadunit(const s : string;compile_system, in_uses : boolean) : pmodule;
+    procedure proc_unit;
+    procedure proc_program(islibrary : boolean);
+
+  implementation
+
+    uses
+       parser;
+
+    {$I innr.inc}
+
+    procedure insertinternsyms(p : psymtable);
+
+      begin
+         p^.insert(new(psyssym,init('CONCAT',in_concat_x)));
+         p^.insert(new(psyssym,init('WRITE',in_write_x)));
+         p^.insert(new(psyssym,init('WRITELN',in_writeln_x)));
+         p^.insert(new(psyssym,init('ASSIGNED',in_assigned_x)));
+         p^.insert(new(psyssym,init('READ',in_read_x)));
+         p^.insert(new(psyssym,init('READLN',in_readln_x)));
+         p^.insert(new(psyssym,init('OFS',in_ofs_x)));
+         p^.insert(new(psyssym,init('SIZEOF',in_sizeof_x)));
+         p^.insert(new(psyssym,init('TYPEOF',in_typeof_x)));
+         p^.insert(new(psyssym,init('LOW',in_low_x)));
+         p^.insert(new(psyssym,init('HIGH',in_high_x)));
+         p^.insert(new(psyssym,init('SEG',in_seg_x)));
+         p^.insert(new(psyssym,init('ORD',in_ord_x)));
+         p^.insert(new(psyssym,init('PRED',in_pred_x)));
+         p^.insert(new(psyssym,init('SUCC',in_succ_x)));
+
+         { for testing purpose }
+         p^.insert(new(psyssym,init('DECI',in_dec_x)));
+         p^.insert(new(psyssym,init('INCI',in_inc_x)));
+         p^.insert(new(psyssym,init('STR',in_str_x_string)));
+      end;
+
+    procedure load_ppu(hp : pmodule;compile_system : boolean);
+
+      var
+         loaded_unit  : pmodule;
+         b            : byte;
+         checksum,
+         count,
+         nextmapentry : longint;
+         hs           : string;
+      begin
+         { init the map }
+         new(hp^.map);
+         nextmapentry:=1;
+
+         { load the used units from interface }
+         hp^.ppufile^.read_data(b,1,count);
+         while (b=ibloadunit) do
+           begin
+              { read unit name }
+              hp^.ppufile^.read_data(hs[0],1,count);
+              hp^.ppufile^.read_data(hs[1],byte(hs[0]),count);
+              hp^.ppufile^.read_data(checksum,4,count);
+              loaded_unit:=loadunit(hs,false,false);
+              if hp^.compiled then
+                exit;
+              { if the crc of a used unit is the same as }
+              { written to the PPU file, we needn't to   }
+              { recompile the current unit               }
+              if (loaded_unit^.crc<>checksum) or
+                 (do_build and loaded_unit^.sources_avail) then
+                begin
+                   { we have to compile the current unit }
+                   { remove stuff which isn't needed     }
+                   { forget the map }
+                   dispose(hp^.map);
+                   hp^.map:=nil;
+                   hp^.ppufile^.close;
+                   dispose(hp^.ppufile,done);
+                   hp^.ppufile:=nil;
+                   compile(hp^.mainsource^,compile_system);
+                   exit;
+                end;
+              { setup the map entry for deref }
+              hp^.map^[nextmapentry]:=loaded_unit^.symtable;
+              inc(nextmapentry);
+
+              if nextmapentry>maxunits then
+               Message(unit_f_too_much_units);
+
+              { read until ibend }
+              hp^.ppufile^.read_data(b,1,count);
+           end;
+
+         { ok, now load the unit }
+         hp^.symtable:=new(punitsymtable,load(hp^.unitname^));
+
+         { if this is the system unit insert the intern }
+         { symbols                                      }
+         if compile_system then
+           insertinternsyms(psymtable(hp^.symtable));
+
+         { now only read the implementation part }
+         hp^.in_implementation:=true;
+
+         { load the used units from implementation }
+         hp^.ppufile^.read_data(b,1,count);
+         while (b<>ibend) and (b=ibloadunit) do
+           begin
+              { read unit name }
+              hp^.ppufile^.read_data(hs[0],1,count);
+              hp^.ppufile^.read_data(hs[1],byte(hs[0]),count);
+              hp^.ppufile^.read_data(checksum,4,count);
+              loaded_unit:=loadunit(hs,false,false);
+              if hp^.compiled then exit;
+              { if the crc of a used unit is the same as }
+              { written to the PPU file, we needn't to   }
+              { recompile the current unit               }
+              { but for the implementation part          }
+              { the written crc is false, because        }
+              { not defined when writing the ppufile !!  }
+              if {(loaded_unit^.crc<>checksum) or}
+                (do_build and loaded_unit^.sources_avail) then
+                begin
+                   { we have to compile the current unit }
+                   { remove stuff which isn't needed     }
+                   { forget the map }
+                   dispose(hp^.map);
+                   hp^.map:=nil;
+                   hp^.ppufile^.close;
+                   dispose(hp^.ppufile,done);
+                   hp^.ppufile:=nil;
+                   compile(hp^.mainsource^,compile_system);
+                   exit;
+                end;
+              { read until ibend }
+              hp^.ppufile^.read_data(b,1,count);
+           end;
+         hp^.ppufile^.close;
+         dispose(hp^.map);
+         hp^.map:=nil;
+      end;
+
+
+    function loadunit(const s : string;compile_system, in_uses : boolean) : pmodule;
+
+      var
+         st : punitsymtable;
+         old_current_module,hp,nextmodule : pmodule;
+         pu : pused_unit;
+         a  : pasmfile;
+         hs : pstring;
+         i  : longint;
+      begin
+         old_current_module:=current_module;
+         { be sure not to mix lines from different files }
+         { update_line; }
+         { unit not found }
+         st:=nil;
+         { search all loaded units }
+         hp:=pmodule(loaded_units.first);
+         while assigned(hp) do
+           begin
+              if hp^.unitname^=s then
+                begin
+                   { the unit is already registered   }
+                   { and this means that the unit     }
+                   { is already compiled              }
+                   { else there is a cyclic unit use  }
+                   if assigned(hp^.symtable) then
+                     st:=punitsymtable(hp^.symtable)
+                   else
+                    begin
+                    { recompile the unit ? }
+                      if (not current_module^.in_implementation) and (hp^.in_implementation) then
+                       Message(unit_f_circular_unit_reference);
+                    end;
+                   break;
+                end;
+              { the next unit }
+              hp:=pmodule(hp^.next);
+           end;
+
+       { no error and the unit isn't loaded }
+         if not(assigned(hp)) and (st=nil) then
+           begin
+              { generates a new unit info record }
+              hp:=new(pmodule,init(s,true));
+              { now we can register the unit }
+              loaded_units.insert(hp);
+
+              current_module:=hp;
+              { force build ? }
+              if (hp^.do_compile) or (hp^.sources_avail and do_build) then
+                begin
+                   { we needn't the ppufile }
+                   if assigned(hp^.ppufile) then
+                     begin
+                        dispose(hp^.ppufile,done);
+                        hp^.ppufile:=nil;
+                     end;
+                   if not(hp^.sources_avail) then
+                    Message1(unit_f_cant_compile_unit,hp^.unitname^)
+                   else
+                    compile(hp^.mainsource^,compile_system);
+                end
+              else
+                begin
+                { only reassemble ? }
+                  if (hp^.do_assemble) then
+                   begin
+                     a:=new(PAsmFile,Init(hp^.asmfilename^));
+                     a^.DoAssemble;
+                     dispose(a,Done);
+                   end;
+                 { we should know there the PPU file else it's an error and
+                   we can't load the unit }
+                  if hp^.ppufile^.name^<>'' then
+                    begin
+                      if (hp^.flags and uf_in_library)=0 then
+                       Linker.AddObjectFile(hp^.objfilename^);
+                      load_ppu(hp,compile_system);
+                    end;
+                end;
+
+              { register the unit _once_ }
+              usedunits.concat(new(pused_unit,init(hp,0)));
+              { the unit is written, so we can set the symtable type }
+              { to unitsymtable, else we get some dupid errors       }
+              { this is not the right place because of the           }
+              { ready label                                          }
+              { psymtable(hp^.symtable)^.symtabletype:=unitsymtable; }
+              { placed at this end of proc_unit                      }
+              psymtable(hp^.symtable)^.unitid:=0;
+              { reset the unitnumbers for the other units }
+              pu:=pused_unit(old_current_module^.used_units.first);
+              while assigned(pu) do
+                begin
+                   psymtable(pu^.u^.symtable)^.unitid:=pu^.unitid;
+                   pu:=pused_unit(pu^.next);
+                end;
+           end
+         else
+           if assigned(hp) and (st=nil) then
+             begin
+                { we have to compile the unit again, but it is already inserted !!}
+                { we may have problem with the lost symtable !! }
+                current_module:=hp;
+                { we must preserve the unit chain }
+                nextmodule:=pmodule(hp^.next);
+                { we have to cleanup a little }
+                hp^.special_done;
+                new(hs);
+                hs^:=hp^.mainsource^;
+                hp^.init(hs^,true);
+                dispose(hs);
+                { we must preserve the unit chain }
+                hp^.next:=nextmodule;
+                if assigned(hp^.ppufile) then
+                 load_ppu(hp,compile_system)
+                else
+                 begin
+                   Message1(parser_d_compiling_second_time,hp^.mainsource^);
+                   compile(hp^.mainsource^,compile_system);
+                 end;
+                current_module^.compiled:=true;
+             end;
+         { set the old module }
+         current_module:=old_current_module;
+         { the current module uses the unit hp }
+         current_module^.used_units.concat(new(pused_unit,init(hp,0)));
+         pused_unit(current_module^.used_units.last)^.in_uses:=in_uses;
+         if in_uses and not current_module^.in_implementation then
+           pused_unit(current_module^.used_units.last)^.in_interface:=true;
+         loadunit:=hp;
+      end;
+
+    procedure loadunits;
+
+      var
+         s : stringid;
+         hp : pused_unit;
+         hp2 : pmodule;
+         hp3 : psymtable;
+         oldprocsym:Pprocsym;
+
+      begin
+         oldprocsym:=aktprocsym;
+         consume(_USES);
+{$ifdef DEBUG}
+         test_symtablestack;
+{$endif DEBUG}
+         repeat
+           s:=pattern;
+           consume(ID);
+           hp2:=loadunit(s,false,true);
+           if current_module^.compiled then
+             exit;
+           refsymtable^.insert(new(punitsym,init(s,hp2^.symtable)));
+
+           if token=COMMA then
+            begin
+              pattern:='';
+              consume(COMMA);
+            end
+           else
+            break;
+         until false;
+         consume(SEMICOLON);
+
+         { now insert the units in the symtablestack }
+         hp:=pused_unit(current_module^.used_units.first);
+         { set the symtable to systemunit so it gets reorderd correctly }
+         symtablestack:=systemunit;
+         while assigned(hp) do
+           begin
+{$IfDef GDB}
+              if (cs_debuginfo in aktswitches) and
+                not hp^.is_stab_written then
+                begin
+                   punitsymtable(hp^.u^.symtable)^.concattypestabto(debuglist);
+                   hp^.is_stab_written:=true;
+                   hp^.unitid:=psymtable(hp^.u^.symtable)^.unitid;
+                end;
+{$EndIf GDB}
+              if hp^.in_uses then
+                begin
+                   hp3:=symtablestack;
+                   while assigned(hp3) do
+                     begin
+                        { insert units only once ! }
+                        if hp^.u^.symtable=hp3 then
+                          break;
+                        hp3:=hp3^.next;
+                        { unit isn't inserted }
+                        if hp3=nil then
+                          begin
+                             psymtable(hp^.u^.symtable)^.next:=symtablestack;
+                             symtablestack:=psymtable(hp^.u^.symtable);
+{$ifdef CHAINPROCSYMS}
+                             symtablestack^.chainprocsyms;
+{$endif CHAINPROCSYMS}
+{$ifdef DEBUG}
+                             test_symtablestack;
+{$endif DEBUG}
+                          end;
+                     end;
+                end;
+              hp:=pused_unit(hp^.next);
+           end;
+          aktprocsym:=oldprocsym;
+      end;
+
+      procedure parse_uses(symt:Psymtable);
+
+      begin
+         if token=_USES then
+           begin
+              current_module^.in_implementation:=true;
+              symt^.symtabletype:=unitsymtable;
+              loadunits;
+              symt^.symtabletype:=globalsymtable;
+{$ifdef DEBUG}
+              test_symtablestack;
+{$endif DEBUG}
+           end;
+      end;
+
+    procedure proc_unit;
+
+      var
+         unitname : stringid;
+{$ifdef GDB}
+         { several defs to simulate more or less C++ objects for GDB }
+         vmtdef : precdef;
+         pvmtdef : ppointerdef;
+         vmtarraydef : parraydef;
+         vmtsymtable : psymtable;
+{$endif GDB}
+         names:Tstringcontainer;
+         p : psymtable;
+         unitst : punitsymtable;
+         pu : pused_unit;
+         { the output ppufile is written to this path }
+         s1,s2,s3:^string; {Saves stack space, but only eats heap
+                            space when there is a lot of heap free.}
+
+      begin
+         consume(_UNIT);
+
+         stringdispose(current_module^.objfilename);
+         stringdispose(current_module^.ppufilename);
+       { create filenames and check unit name }
+         new(s1);
+         new(s2);
+         new(s3);
+         s1^:=FixFileName(current_module^.current_inputfile^.path^+current_module^.current_inputfile^.name^);
+         current_module^.objfilename:=stringdup(s1^+target_info.objext);
+         current_module^.ppufilename:=stringdup(s1^+target_info.unitext);
+
+         s1^:=upper(pattern);
+         s2^:=upper(target_info.system_unit);
+         s3^:=upper(current_module^.current_inputfile^.name^);
+         if (cs_compilesystem in aktswitches)  then
+          begin
+            if (cs_check_unit_name in aktswitches) and
+               ((length(pattern)>8) or (s1^<>s2^) or (s1^<>s3^)) then
+                Message1(unit_e_illegal_unit_name,s1^);
+          end
+         else
+          if (s1^=s2^) then
+           Message(unit_w_switch_us_missed);
+         dispose(s3);
+         dispose(s2);
+         dispose(s1);
+
+       { add object }
+         Linker.AddObjectFile(current_module^.objfilename^);
+
+         unitname:=pattern;
+
+         consume(ID);
+         consume(SEMICOLON);
+         consume(_INTERFACE);
+
+         { this should be placed after uses !!}
+{$ifndef UseNiceNames}
+         procprefix:='_'+unitname+'$$';
+{$else UseNiceNames}
+         procprefix:='_'+tostr(length(unitname))+lowercase(unitname)+'_';
+{$endif UseNiceNames}
+
+         parse_only:=true;
+
+         { generate now the global symboltable }
+         p:=new(punitsymtable,init(globalsymtable,unitname));
+         refsymtable:=p;
+         unitst:=punitsymtable(p);
+
+         { set the symbol table for the current unit }
+         { this must be set later for interdependency }
+         { current_module^.symtable:=psymtable(p); }
+
+         { a unit compiled at command line must be inside the loaded_unit list }
+         if (compile_level=1) then
+           begin
+              current_module^.unitname:=stringdup(unitname);
+              loaded_units.insert(current_module);
+              if cs_unit_to_lib in initswitches then
+                begin
+                current_module^.flags:=current_module^.flags or uf_in_library;
+                if cs_shared_lib in initswitches then
+                  current_module^.flags:=current_module^.flags or uf_shared_library;
+                end;
+           end;
+
+
+         { insert qualifier for the system unit (allows system.writeln) }
+         if not(cs_compilesystem in aktswitches) then
+           begin
+              { insert the system unit }
+              { it is allways the first }
+              systemunit^.next:=nil;
+              symtablestack:=systemunit;
+              refsymtable^.insert(new(punitsym,init('SYSTEM',systemunit)));
+
+              if token=_USES then
+                begin
+                   unitst^.symtabletype:=unitsymtable;
+                   loadunits;
+                   { has it been compiled at a higher level ?}
+                   if current_module^.compiled then
+                     exit;
+                   unitst^.symtabletype:=globalsymtable;
+                end;
+
+              { ... but insert the symbol table later }
+              p^.next:=symtablestack;
+              symtablestack:=p;
+           end
+         else
+         { while compiling a system unit, some types are directly inserted }
+           begin
+              p^.next:=symtablestack;
+              symtablestack:=p;
+              p^.insert(new(ptypesym,init('longint',s32bitdef)));
+              p^.insert(new(ptypesym,init('ulong',u32bitdef)));
+              p^.insert(new(ptypesym,init('void',voiddef)));
+              p^.insert(new(ptypesym,init('char',cchardef)));
+{$ifdef i386}
+              p^.insert(new(ptypesym,init('s64real',c64floatdef)));
+{$endif i386}
+              p^.insert(new(ptypesym,init('s80real',s80floatdef)));
+              p^.insert(new(ptypesym,init('cs32fixed',s32fixeddef)));
+              p^.insert(new(ptypesym,init('byte',u8bitdef)));
+              p^.insert(new(ptypesym,init('string',cstringdef)));
+              p^.insert(new(ptypesym,init('word',u16bitdef)));
+              p^.insert(new(ptypesym,init('boolean',booldef)));
+              p^.insert(new(ptypesym,init('void_pointer',voidpointerdef)));
+              p^.insert(new(ptypesym,init('file',cfiledef)));
+{$ifdef i386}
+              p^.insert(new(ptypesym,init('REAL',new(pfloatdef,init(s64real)))));
+              p^.insert(new(ptypesym,init('COMP',new(pfloatdef,init(s64bit)))));
+              p^.insert(new(ptypesym,init('EXTENDED',new(pfloatdef,init(s80real)))));
+{$endif}
+{$ifdef m68k}
+              { internal definitions }
+              p^.insert(new(ptypesym,init('s32real',c64floatdef)));
+              { mappings... }
+              p^.insert(new(ptypesym,init('REAL',new(pfloatdef,init(s32real)))));
+              if (cs_fp_emulation) in aktswitches then
+                   p^.insert(new(ptypesym,init('DOUBLE',new(pfloatdef,init(s32real)))))
+              else
+                   p^.insert(new(ptypesym,init('DOUBLE',new(pfloatdef,init(s64real)))));
+{              p^.insert(new(ptypesym,init('COMP',new(pfloatdef,init(s32real)))));}
+              if (cs_fp_emulation) in aktswitches then
+                   p^.insert(new(ptypesym,init('EXTENDED',new(pfloatdef,init(s32real)))))
+              else
+                   p^.insert(new(ptypesym,init('EXTENDED',new(pfloatdef,init(s80real)))));
+{$endif}
+              p^.insert(new(ptypesym,init('SINGLE',new(pfloatdef,init(s32real)))));
+              p^.insert(new(ptypesym,init('POINTER',new(ppointerdef,init(voiddef)))));
+              p^.insert(new(ptypesym,init('STRING',cstringdef)));
+              p^.insert(new(ptypesym,init('BOOLEAN',new(porddef,init(bool8bit,0,1)))));
+              p^.insert(new(ptypesym,init('CHAR',new(porddef,init(uchar,0,255)))));
+              p^.insert(new(ptypesym,init('TEXT',new(pfiledef,init(ft_text,nil)))));
+              p^.insert(new(ptypesym,init('CARDINAL',new(porddef,init(u32bit,0,$ffffffff)))));
+              p^.insert(new(ptypesym,init('FIXED',new(pfloatdef,init(f32bit)))));
+              p^.insert(new(ptypesym,init('FIXED16',new(pfloatdef,init(f16bit)))));
+              p^.insert(new(ptypesym,init('TYPEDFILE',new(pfiledef,init(ft_typed,voiddef)))));
+              { !!!!!
+              p^.insert(new(ptypesym,init('COMP',new(porddef,init(s64bit,0,0)))));
+              p^.insert(new(ptypesym,init('SINGLE',new(porddef,init(s32real,0,0)))));
+              p^.insert(new(ptypesym,init('EXTENDED',new(porddef,init(s80real,0,0)))));
+              p^.insert(new(ptypesym,init('FILE',new(pfiledef,init(ft_untyped,nil)))));
+              }
+              { Add a type for virtual method tables in lowercase }
+              { so it isn't reachable!                            }
+{$ifdef GDB}
+              vmtsymtable:=new(psymtable,init(recordsymtable));
+              vmtdef:=new(precdef,init(vmtsymtable));
+              pvmtdef:=new(ppointerdef,init(vmtdef));
+              vmtsymtable^.insert(new(pvarsym,init('parent',pvmtdef)));
+              vmtsymtable^.insert(new(pvarsym,init('length',globaldef('longint'))));
+              vmtsymtable^.insert(new(pvarsym,init('mlength',globaldef('longint'))));
+              vmtarraydef:=new(parraydef,init(0,1,s32bitdef));
+              vmtarraydef^.definition := voidpointerdef;
+              vmtsymtable^.insert(new(pvarsym,init('__pfn',vmtarraydef)));
+              p^.insert(new(ptypesym,init('__vtbl_ptr_type',vmtdef)));
+              p^.insert(new(ptypesym,init('pvmt',pvmtdef)));
+              vmtarraydef:=new(parraydef,init(0,1,s32bitdef));
+              vmtarraydef^.definition := pvmtdef;
+              p^.insert(new(ptypesym,init('vtblarray',vmtarraydef)));
+              insertinternsyms(p);
+{$endif GDB}
+           end;
+
+         { displaced for inter-dependency considerations }
+         current_module^.symtable:=psymtable(p);
+
+         constsymtable:=symtablestack;
+         { ... parse the declarations }
+         read_interface_declarations;
+         consume(_IMPLEMENTATION);
+
+         parse_only:=false;
+         refsymtable^.number_defs;
+
+{$ifdef GDB}
+         { add all used definitions even for implementation}
+         if (cs_debuginfo in aktswitches) then
+           begin
+              { all types }
+              punitsymtable(refsymtable)^.concattypestabto(debuglist);
+              { and all local symbols}
+              refsymtable^.concatstabto(debuglist);
+           end;
+{$endif GDB}
+         { for interdependent units
+         the crc is included in the ppufile
+         but it is not known when writing the first ppufile
+         so I tried to add a fake writing of the ppu
+         just to get the CRC
+         but the result is different for the real CRC
+         it calculates after, I don't know why
+
+         Answer:
+         -------
+         When reading the interface part, the compiler assumes
+         that all registers are modified by a procedure
+         usedinproc:=$ff !
+         If the definition is read, the compiler determines
+         the used registers and write the correct value
+         to usedinproc
+
+         only_calculate_crc:=true;
+         writeunitas(current_module^.current_inputfile^.path^+current_module^.current_inputfile^.name^+
+                     +'.PPS',punitsymtable(symtablestack));
+         only_calculate_crc:=false;
+         }
+         { generates static symbol table }
+         p:=new(punitsymtable,init(staticsymtable,unitname));
+         refsymtable:=p;
+
+         {Generate a procsym.}
+         aktprocsym:=new(Pprocsym,init(unitname+'_init'));
+         aktprocsym^.definition:=new(Pprocdef,init);
+         aktprocsym^.definition^.options:=aktprocsym^.definition^.options or pounitinit;
+         aktprocsym^.definition^.setmangledname(unitname+'_init');
+
+         {The generated procsym has a local symtable. Discard it and turn
+          it into the static one.}
+         dispose(aktprocsym^.definition^.localst,done);
+         aktprocsym^.definition^.localst:=p;
+
+         names.init;
+         names.insert(unitname+'_init');
+
+         { testing !!!!!!!!! }
+         { we set the interface part as a unitsymtable  }
+         { for the case we need to compile another unit }
+
+         { remove the globalsymtable from the symtable stack }
+         { to reinsert it after loading the implementation units }
+         symtablestack:=unitst^.next;
+
+         parse_uses(unitst);
+
+         { duplicated here to be sure }
+{$ifndef UseNiceNames}
+         procprefix:='_'+unitname+'$$';
+{$else UseNiceNames}
+         procprefix:='_'+tostr(length(unitname))+lowercase(unitname)+'_';
+{$endif UseNiceNames}
+
+         { but reinsert the global symtable as lasts }
+         unitst^.next:=symtablestack;
+         symtablestack:=unitst;
+
+{$ifdef DEBUG}
+         test_symtablestack;
+{$endif DEBUG}
+         constsymtable:=symtablestack;
+
+{$ifdef Splitheap}
+         if testsplit then
+           begin
+              Split_Heap;
+              allow_special:=true;
+              Switch_to_temp_heap;
+           end;
+{$endif Splitheap}
+
+{$ifdef Splitheap}
+         { it will report all crossings }
+         allow_special:=false;
+{$endif Splitheap}
+         { set some informations }
+         procinfo.retdef:=voiddef;
+         procinfo._class:=nil;
+         procinfo.call_offset:=8;
+
+         { for temporary values }
+         procinfo.framepointer:=frame_pointer;
+
+         { clear flags }
+         procinfo.flags:=0;
+
+         {Reset the codegenerator.}
+         codegen_newprocedure;
+
+         names.insert('INIT$$'+unitname);
+
+         compile_proc_body(names,true,false);
+
+         codegen_doneprocedure;
+
+         consume(POINT);
+
+         names.done;
+
+         { size of the static data }
+         datasize:=symtablestack^.datasize;
+
+         { unsed static symbols ? }
+         symtablestack^.allsymbolsused;
+
+{$ifdef GDB}
+         { add all used definitions even for implementation}
+         if (cs_debuginfo in aktswitches) then
+            begin
+                  { all types }
+                  punitsymtable(symtablestack)^.concattypestabto(debuglist);
+                  { and all local symbols}
+                  symtablestack^.concatstabto(debuglist);
+            end;
+{$endif GDB}
+
+         current_module^.in_implementation:=false;
+         { deletes all symtables generated in the implementation part }
+         while symtablestack^.symtabletype<>globalsymtable do
+           dellexlevel;
+
+         { tests, if all forwards are resolved }
+         symtablestack^.check_forwards;
+         symtablestack^.symtabletype:=unitsymtable;
+         punitsymtable(symtablestack)^.is_stab_written:=false;
+
+         {Write out the unit if the compile was succesfull.}
+         if errorcount=0 then
+          writeunitas(current_module^.ppufilename^,punitsymtable(symtablestack));
+
+         pu:=pused_unit(usedunits.first);
+         while assigned(pu) do
+           begin
+              punitsymtable(pu^.u^.symtable)^.is_stab_written:=false;
+              pu:=pused_unit(pu^.next);
+           end;
+         inc(datasize,symtablestack^.datasize);
+      end;
+
+    procedure proc_program(islibrary : boolean);
+
+      var
+         i : longint;
+         st : psymtable;
+         programname : stringid;
+         names:Tstringcontainer;
+      begin
+         { Trying to compile the system unit... }
+         { if no unit defined... then issue a   }
+         { fatal error (avoids pointer problems)}
+         { when referencing the non-existant    }
+         { system unit.                         }
+         if (cs_compilesystem in aktswitches) then
+         Begin
+           if token<>_UNIT then
+            Message1(scan_f_syn_expected,'UNIT');
+           consume(_UNIT);
+         end;
+
+         parse_only:=false;
+         programname:='';
+
+         if islibrary then
+           begin
+              consume(_LIBRARY);
+              programname:=pattern;
+              consume(ID);
+              consume(SEMICOLON);
+           end
+         else
+           { is there an program head ? }
+           if token=_PROGRAM then
+           begin
+              consume(_PROGRAM);
+              programname:=pattern;
+              consume(ID);
+              if token=LKLAMMER then
+                begin
+                   consume(LKLAMMER);
+                   idlist;
+                   consume(RKLAMMER);
+                end;
+              consume(SEMICOLON);
+           end;
+
+         { insert after the unit symbol tables the static symbol table }
+         { of the program                                              }
+         st:=new(punitsymtable,init(staticsymtable,programname));
+
+         {Generate a procsym.}
+         aktprocsym:=new(Pprocsym,init('program_init'));
+         aktprocsym^.definition:=new(Pprocdef,init);
+         aktprocsym^.definition^.options:=aktprocsym^.definition^.options or poproginit;
+         aktprocsym^.definition^.setmangledname('program_init');
+         {The localst is a local symtable. Change it into the static
+          symtable.}
+         dispose(aktprocsym^.definition^.localst,done);
+         aktprocsym^.definition^.localst:=st;
+
+         names.init;
+         names.insert('program_init');
+
+         refsymtable:=st;
+
+         {Insert the symbols of the system unit into the stack of symbol
+          tables.}
+         symtablestack:=systemunit;
+         systemunit^.next:=nil;
+         refsymtable^.insert(new(punitsym,init('SYSTEM',systemunit)));
+
+         {Load the units used by the program we compile.}
+         if token=_USES then loadunits;
+
+         {Insert the name of the main program into the symbol table.}
+         if programname<>'' then
+           st^.insert(new(pprogramsym,init(programname)));
+
+         { ...is also constsymtable, this is the symtable where }
+         { the elements of enumeration types are inserted       }
+         constsymtable:=st;
+
+         codegen_newprocedure;
+
+         { set some informations about the main program }
+         procinfo.retdef:=voiddef;
+         procinfo._class:=nil;
+         procinfo.call_offset:=8;
+
+         {Set the framepointer of the program initialization to the
+          default framepointer (EBP on i386).}
+         procinfo.framepointer:=frame_pointer;
+
+         { clear flags }
+         procinfo.flags:=0;
+
+         procprefix:='';
+         in_except_block:=false;
+
+
+         {The program intialization needs an alias, so it can be called
+          from the bootstrap code.}
+         case target_info.target of
+            target_GO32V1,
+            target_GO32V2,
+            target_OS2,
+            target_WIN32:
+              names.insert('_main');
+            target_LINUX:
+              names.insert('main');
+         end;
+         names.insert('PASCALMAIN');
+
+         compile_proc_body(names,true,false);
+
+         codegen_doneprocedure;
+
+         Linker.AddObjectFile(current_module^.unitname^);
+         current_module^.linkofiles.insert(current_module^.unitname^);
+
+        { On the Macintosh Classic M68k Architecture   }
+        { The Heap variable is simply a POINTER to the }
+        { real HEAP. The HEAP must be set up by the RTL }
+        { and must store the pointer in this value.    }
+         if (target_info.target = target_MAC68k) then
+          bsssegment^.concat(new(pai_datablock,init_global('HEAP',4)))
+         else
+          bsssegment^.concat(new(pai_datablock,init_global('HEAP',heapsize)));
+         if target_info.target=target_GO32V2 then
+           begin
+              { stacksize can be specified }
+              datasegment^.concat(new(pai_symbol,init_global('__stklen')));
+              datasegment^.concat(new(pai_const,init_32bit(stacksize)));
+           end;
+         if (target_info.target=target_WIN32) then
+           begin
+              { generate the last entry for the imports directory }
+              if not(assigned(importssection)) then
+                importssection:=new(paasmoutput,init);
+              { $3 ensure that it is the last entry, all other entries }
+              { are written to $2                                      }
+              importssection^.concat(new(pai_section,init('.idata$3')));
+              for i:=1 to 5 do
+                importssection^.concat(new(pai_const,init_32bit(0)));
+           end;
+
+         {I prefer starting with a heapsize of 256K in OS/2. The heap can
+          grow later until the size specified on the command line. Allocating
+          four megs at once can hurt performance when more programs are in
+          memory.}
+         datasegment^.concat(new(pai_symbol,init_global('HEAPSIZE')));
+         if target_info.target=target_OS2 then
+          heapsize:=256*1024;
+         datasegment^.concat(new(pai_const,init_32bit(heapsize)));
+         datasize:=symtablestack^.datasize;
+
+         names.done;
+
+         consume(POINT);
+
+         symtablestack^.check_forwards;
+         symtablestack^.allsymbolsused;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.43  1998/03/20 23:31:34  florian
+    * bug0113 fixed
+    * problem with interdepened units fixed ("options.pas problem")
+    * two small extensions for future AMD 3D support
+
+  Revision 1.42  1998/03/11 22:22:52  florian
+    * Fixed circular unit uses, when the units are not in the current dir (from Peter)
+    * -i shows correct info, not <lf> anymore (from Peter)
+    * linking with shared libs works again (from Peter)
+
+  Revision 1.41  1998/03/10 17:19:29  peter
+    * fixed bug0108
+    * better linebreak scanning (concentrated in nextchar(), it supports
+      #10, #13, #10#13, #13#10
+
+  Revision 1.40  1998/03/10 16:27:42  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.39  1998/03/10 01:17:24  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.38  1998/03/05 22:43:50  florian
+    * some win32 support stuff added
+
+  Revision 1.37  1998/03/04 01:35:08  peter
+    * messages for unit-handling and assembler/linker
+    * the compiler compiles without -dGDB, but doesn't work yet
+    + -vh for Hint
+
+  Revision 1.36  1998/03/03 23:18:45  florian
+    * ret $8 problem with unit init/main program fixed
+
+  Revision 1.35  1998/03/02 13:38:48  peter
+    + importlib object
+    * doesn't crash on a systemunit anymore
+    * updated makefile and depend
+
+  Revision 1.34  1998/03/02 01:49:04  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.33  1998/03/01 22:46:20  florian
+    + some win95 linking stuff
+    * a couple of bugs fixed:
+      bug0055,bug0058,bug0059,bug0064,bug0072,bug0093,bug0095,bug0098
+
+  Revision 1.32  1998/02/28 09:30:58  florian
+    + writing of win32 import section added
+
+  Revision 1.31  1998/02/28 03:57:08  carl
+    + replaced target_info.short_name by target_info.target (a bit faster)
+
+  Revision 1.30  1998/02/27 09:25:58  daniel
+  * Changed symtable handling so no junk symtable is put on the symtablestack.
+
+  Revision 1.28  1998/02/24 14:20:54  peter
+    + tstringcontainer.empty
+    * ld -T option restored for linux
+    * libraries are placed before the objectfiles in a .PPU file
+    * removed 'uses link' from files.pas
+
+  Revision 1.27  1998/02/24 00:19:19  peter
+    * makefile works again (btw. linux does like any char after a \ )
+    * removed circular unit with assemble and files
+    * fixed a sigsegv in pexpr
+    * pmodule init unit/program is the almost the same, merged them
+
+  Revision 1.26  1998/02/22 23:55:18  peter
+    * small fix
+
+  Revision 1.25  1998/02/22 23:03:28  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.24  1998/02/22 18:51:06  carl
+    * where the heck did the HEAP for m68k go??????? REINSTATED
+
+  Revision 1.23  1998/02/21 05:50:14  carl
+    * bugfix of crash with Us switch
+
+  Revision 1.22  1998/02/19 00:11:08  peter
+    * fixed -g to work again
+    * fixed some typos with the scriptobject
+
+  Revision 1.21  1998/02/17 21:20:57  peter
+    + Script unit
+    + __EXIT is called again to exit a program
+    - target_info.link/assembler calls
+    * linking works again for dos
+    * optimized a few filehandling functions
+    * fixed stabs generation for procedures
+
+  Revision 1.20  1998/02/16 12:51:38  michael
+  + Implemented linker object
+
+  Revision 1.19  1998/02/14 01:45:29  peter
+    * more fixes
+    - pmode target is removed
+    - search_as_ld is removed, this is done in the link.pas/assemble.pas
+    + findexe() to search for an executable (linker,assembler,binder)
+
+  Revision 1.18  1998/02/13 22:26:37  peter
+    * fixed a few SigSegv's
+    * INIT$$ was not written for linux!
+    * assembling and linking works again for linux and dos
+    + assembler object, only attasmi3 supported yet
+    * restore pp.pas with AddPath etc.
+
+  Revision 1.17  1998/02/13 10:35:27  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.16  1998/02/12 17:19:22  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.15  1998/02/12 11:50:28  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.14  1998/01/30 17:31:26  pierre
+    * bug of cyclic symtablestack fixed
+
+  Revision 1.13  1998/01/28 13:48:49  michael
+  + Initial implementation for making libs from within FPC. Not tested, as compiler does not run
+
+  Revision 1.12  1998/01/19 15:46:25  peter
+  * fixed INIT$$lowercase generation
+
+  Revision 1.11  1998/01/19 09:32:28  michael
+  * Shared Lib and GDB/RHIDE Bufixes from Peter Vreman.
+
+  Revision 1.10  1998/01/17 01:57:39  michael
+  + Start of shared library support. First working version.
+
+  Revision 1.9  1998/01/16 18:03:17  florian
+    * small bug fixes, some stuff of delphi styled constructores added
+
+  Revision 1.8  1998/01/13 23:11:15  florian
+    + class methods
+
+  Revision 1.7  1998/01/13 17:13:09  michael
+  * File time handling and file searching is now done in an OS-independent way,
+    using the new file treating functions in globals.pas.
+
+  Revision 1.6  1998/01/13 16:16:03  pierre
+    *  bug in interdependent units handling
+       - primary unit was not in loaded_units list
+       - current_module^.symtable was assigned too early
+       - donescanner must not call error if the compilation
+       of the unit was done at a higher level.
+
+  Revision 1.5  1998/01/12 13:03:32  florian
+    + parsing of class methods implemented
+
+  Revision 1.4  1998/01/11 10:54:24  florian
+    + generic library support
+
+  Revision 1.3  1998/01/11 04:17:36  carl
+  + floating point support for m68k
+
+  Revision 1.2  1998/01/09 09:10:01  michael
+  + Initial implementation, second try
+
+}

compiler/pp.pas

@@ -0,0 +1,523 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl
+
+    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.
+
+ ****************************************************************************}
+
+{
+  possible compiler switches (* marks a currently required switch):
+  -----------------------------------------------------------------
+  USE_RHIDE           generates errors and warning in an format recognized
+                      by rhide
+  TP                  to compile the compiler with Turbo or Borland Pascal
+  GDB*                support of the GNU Debugger
+  I386                generate a compiler for the Intel i386+
+  M68K                generate a compiler for the M68000
+  MULLER              release special debug code of Pierre Muller
+                      (needs some extra units)
+  USEOVERLAY          compiles a TP version which uses overlays
+  EXTDEBUG            some extra debug code is executed
+  SUPPORT_MMX         only i386: releases the compiler switch
+                      MMX which allows the compiler to generate
+                      MMX instructions
+  EXTERN_MSG          Don't compile the msgfiles in the compiler, always
+                      use external messagefiles
+  -----------------------------------------------------------------
+
+  Required switches for a i386 compiler be compiled by Free Pascal Compiler:
+  GDB;I386
+
+  Required switches for a i386 compiler be compiled by Turbo Pascal:
+  GDB;I386;TP
+
+  Required switches for a 68000 compiler be compiled by Turbo Pascal:
+  GDB;M68k;TP
+}
+
+{$ifdef FPC}
+   {$ifndef GDB}
+      {$error The compiler switch GDB must be defined}
+   {$endif GDB}
+   {$ifndef I386}
+      {$ifndef M68K}
+        {$error One of the switches I386 or M68K must be defined}
+      {$endif M68K}
+   {$endif I386}
+   {$ifdef support_mmx}
+     {$ifndef i386}
+       {$error I386 switch must be on}
+     {$endif i386}
+   {$endif support_mmx}
+{$endif}
+
+{$ifdef TP}
+  {$IFNDEF DPMI}
+    {$M 24576,0,655360}
+  {$ELSE}
+    {$M 49152}
+  {$ENDIF DPMI}
+  {$E+,N+,F+,S-,R-}
+{$endif TP}
+
+
+program pp;
+
+{$IFDEF TP}
+  {$UNDEF PROFILE}
+  {$IFDEF DPMI}
+    {$UNDEF USEOVERLAY}
+  {$ENDIF}
+{$ENDIF}
+{$ifdef FPC}
+  {$UNDEF USEOVERLAY}
+  {$UNDEF USEPMD}
+{$ENDIF}
+
+uses
+{$ifdef fpc}
+  {$ifdef GO32V2}
+    emu387,
+    dpmiexcp,
+  {$endif GO32V2}
+{$endif}
+{$ifdef useoverlay}
+  {$ifopt o+}
+    Overlay,ppovin,
+  {$else}
+  { warn when not $O+ is used }
+    - You must compile with the $O+ switch
+  {$endif}
+{$endif useoverlay}
+{$ifdef lock}
+  lock,
+{$endif lock}
+{$ifdef profile}
+  profile,
+{$endif profile}
+{$ifdef muller}
+  openfile,
+  {$ifdef usepmd}
+    usepmd,
+  {$endif usepmd}
+{$endif}
+{$ifdef LINUX}
+  catch,
+{$endif LINUX}
+  dos,objects,cobjects,
+  globals,parser,systems,tree,symtable,options,link,import,files,
+  verb_def,verbose;
+
+{$ifdef useoverlay}
+  {$O files}
+  {$O globals}
+  {$O hcodegen}
+  {$O pass_1}
+  {$O tree}
+  {$O types}
+  {$O objects}
+  {$O options}
+  {$O cobjects}
+  {$O globals}
+  {$O systems}
+  {$O parser}
+  {$O dos}
+  {$O scanner}
+  {$O symtable}
+  {$O objects}
+  {$O aasm}
+  {$ifdef gdb}
+    {$O gdb}
+  {$endif gdb}
+  {$ifdef i386}
+    {$O opts386}
+    {$O cgi386}
+    {$O aopt386}
+    {$O cgai386}
+    {$O i386}
+    {$O radi386}
+    {$O rai386}
+    {$O ratti386}
+    {$O tgeni386}
+  {$endif}
+  {$ifdef m68k}
+    {$O opts68k}
+    {$O cg68k}
+    {$O ra68k}
+    {$O ag68kgas}
+  {$endif}
+{$endif useoverlay}
+
+
+function print_status(const status : tcompilestatus) : boolean;
+begin
+  print_status:=false;
+  if (abslines=1) then
+   Message1(general_i_kb_free,tostr(memavail shr 10));
+  if (status.currentline mod 100=0) then
+   Message2(general_l_lines_and_free,tostr(status.currentline),tostr(memavail shr 10));
+{$ifdef tp}
+  if (use_big) then
+   begin
+   {$ifdef dpmi}
+     Message1(general_i_stream_kb_free,tostr(symbolstream.getsize shr 10));
+   {$else}
+     Message1(general_i_ems_kb_free,tostr(symbolstream.getsize shr 10));
+   {$endif}
+   end;
+{$endif}
+end;
+
+
+function getrealtime : real;
+var
+  h,m,s,s100 : word;
+begin
+  dos.gettime(h,m,s,s100);
+  getrealtime:=h*3600.0+m*60.0+s+s100/100.0;
+end;
+
+
+
+var
+  oldexit : pointer;
+procedure myexit;{$ifndef FPC}far;{$endif}
+begin
+  exitproc:=oldexit;
+{$ifdef tp}
+  if use_big then
+   symbolstream.done;
+{$endif}
+  if (erroraddr<>nil) then
+   begin
+     case exitcode of
+      202 : begin
+              erroraddr:=nil;
+              Writeln('Error: Stack Overflow');
+            end;
+      203 : begin
+              erroraddr:=nil;
+              Writeln('Error: Out of memory');
+            end;
+     end;
+   {when the module is assigned, then the messagefile is also loaded}
+     if assigned(current_module) and assigned(current_module^.current_inputfile) then
+      Writeln('Compilation aborted at line ',current_module^.current_inputfile^.line_no);
+   end;
+end;
+
+
+{$ifdef tp}
+  procedure do_streamerror;
+  begin
+    if symbolstream.status=-2 then
+     WriteLn('Error: Not enough EMS memory')
+    else
+     WriteLn('Error: EMS Error ',symbolstream.status);
+  {$ifndef MULLER}
+    halt(1);
+  {$else MULLER}
+    runerror(190);
+  {$endif MULLER}
+  end;
+
+  {$ifdef USEOVERLAY}
+    function _heaperror(size:word):integer;far;
+    type
+      heaprecord=record
+        next:pointer;
+        values:longint;
+      end;
+    var
+      l,m:longint;
+    begin
+      l:=ovrgetbuf-ovrminsize;
+      if (size>maxavail) and (l>=size) then
+       begin
+         m:=((longint(size)+$3fff) and $ffffc000);
+         {Clear the overlay buffer.}
+         ovrclearbuf;
+         {Shrink it.}
+         ovrheapend:=ovrheapend-m shr 4;
+         heaprecord(ptr(ovrheapend,0)^).next:=freelist;
+         heaprecord(ptr(ovrheapend,0)^).values:=m shl 12;
+         heaporg:=ptr(ovrheapend,0);
+         freelist:=heaporg;
+         Writeln('Warning: Overlay buffer shrinked, because of memory shortage');
+         _heaperror:=2;
+       end
+      else
+       _heaperror:=0;
+    end;
+  {$endif USEOVERLAY}
+{$endif TP}
+
+
+
+var
+  start : real;
+{$IfDef Extdebug}
+  EntryMemAvail : longint;
+{$EndIf}
+begin
+  oldexit:=exitproc;
+  exitproc:=@myexit;
+
+  start:=getrealtime;
+{$ifdef EXTDEBUG}
+   EntryMemAvail:=MemAvail;
+{$endif}
+{$ifdef MULLER}
+  {$ifdef DPMI}
+     HeapBlock:=$ff00;
+  {$endif DPMI}
+{$endif MULLER}
+{$ifdef TP}
+  {$IFDEF USEOVERLAY}
+    heaperror:=@_heaperror;
+  {$ENDIF USEOVERLAY}
+   if use_big then
+    begin
+      streamerror:=@do_streamerror;
+    { symbolstream.init('TMPFILE',stcreate,16000); }
+    {$ifndef dpmi}
+      symbolstream.init(10000,4000000); {using ems streams}
+    {$else}
+      symbolstream.init(1000000,16000); {using memory streams}
+    {$endif}
+      if symbolstream.errorinfo=stiniterror then
+       do_streamerror;
+    { write something, because pos 0 means nil pointer }
+      symbolstream.writestr(@inputfile);
+    end;
+{$endif tp}
+
+{$ifndef TP}
+   compilestatusproc:=@print_status;
+{$else}
+   compilestatusproc:=print_status;
+{$endif}
+
+   { inits which need to be done  before the arguments are parsed }
+   get_exepath;
+   init_tree;
+   globalsinit;
+   init_symtable;
+   linker.init;
+
+   { read the arguments }
+   read_arguments;
+
+   { inits which depend on arguments }
+   initparser;
+   initimport;
+
+   {show some info}
+   Message1(general_i_compilername,FixFileName(paramstr(0)));
+   Message1(general_i_unitsearchpath,unitsearchpath);
+   Message1(general_d_sourceos,source_info.source_name);
+   Message1(general_i_targetos,target_info.target_name);
+   Message1(general_u_exepath,exepath);
+{$ifdef linux}
+   Message1(general_u_gcclibpath,Linker.gcclibrarypath);
+{$endif}
+
+   compile(inputdir+inputfile+inputextension,false);
+
+   if errorcount=0 then
+    begin
+      start:=getrealtime-start;
+      Message2(general_i_abslines_compiled,tostr(abslines),tostr(trunc(start))+'.'+tostr(trunc(frac(start)*10)));
+    end;
+
+   clearnodes;
+   done_symtable;
+{$ifdef EXTDEBUG}
+   Comment(V_Info,'Memory lost = '+tostr(EntryMemAvail-MemAvail));
+{$endif EXTDEBUG}
+{ exits with error 1 if no codegeneration }
+   if errorcount=0 then
+    halt(0)
+   else
+    halt(1);
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:14  root
+  Initial revision
+
+  Revision 1.40  1998/03/16 22:42:21  florian
+    * some fixes of Peter applied:
+      ofs problem, profiler support
+
+  Revision 1.39  1998/03/10 15:20:30  carl
+    * bugfix of spelling mistake
+     * make it compile under TP with overlays
+
+  Revision 1.38  1998/03/10 13:23:00  florian
+    * small win32 problems fixed
+
+  Revision 1.37  1998/03/10 01:17:24  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.36  1998/03/06 00:52:46  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.35  1998/03/05 02:44:16  peter
+    * options cleanup and use of .msg file
+
+  Revision 1.34  1998/03/04 17:33:52  michael
+  + Changed ifdef FPK to ifdef FPC
+
+  Revision 1.33  1998/03/02 23:08:42  florian
+    * the concatcopy bug removed (solves problems when compilg sysatari!)
+
+  Revision 1.32  1998/03/02 16:02:04  peter
+    * new style messages for pp.pas
+    * cleanup of pp.pas
+
+  Revision 1.31  1998/03/02 13:38:49  peter
+    + importlib object
+    * doesn't crash on a systemunit anymore
+    * updated makefile and depend
+
+  Revision 1.30  1998/03/02 01:49:05  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.29  1998/02/25 14:31:28  jonas
+    * added $d- for TP compiling (disable strict var checking) and removed a duplicate $M statement
+
+  Revision 1.28  1998/02/22 23:03:29  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.27  1998/02/16 14:19:15  florian
+  *** empty log message ***
+
+  Revision 1.26  1998/02/16 13:46:43  michael
+  + Further integration of linker object:
+    - all options pertaining to linking go directly to linker object
+    - removed redundant variables/procedures, especially in OS_TARG...
+
+  Revision 1.25  1998/02/16 12:51:40  michael
+  + Implemented linker object
+
+  Revision 1.24  1998/02/14 05:04:49  carl
+    + more overlay stuff for m68k target
+
+  Revision 1.23  1998/02/14 01:45:30  peter
+    * more fixes
+    - pmode target is removed
+    - search_as_ld is removed, this is done in the link.pas/assemble.pas
+    + findexe() to search for an executable (linker,assembler,binder)
+
+  Revision 1.22  1998/02/13 22:26:39  peter
+    * fixed a few SigSegv's
+    * INIT$$ was not written for linux!
+    * assembling and linking works again for linux and dos
+    + assembler object, only attasmi3 supported yet
+    * restore pp.pas with AddPath etc.
+
+  Revision 1.18  1998/02/03 22:13:34  florian
+    * clean up
+
+  Revision 1.17  1998/02/02 00:55:33  peter
+    * defdatei -> deffile and some german comments to english
+    * search() accepts : as seperater under linux
+    * search for ppc.cfg doesn't open a file (and let it open)
+    * reorganize the reading of parameters/file a bit
+    * all the PPC_ environments are now for all platforms
+
+  Revision 1.16  1998/01/27 10:48:19  florian
+    * dpmiexcp is now always used by a go32v2 compiler executable
+
+  Revision 1.15  1998/01/25 18:45:50  peter
+    + Search for as and ld at startup
+    + source_info works the same as target_info
+    + externlink allows only external linking
+
+  Revision 1.14  1998/01/23 10:46:42  florian
+    * small problems with FCL object model fixed, objpas?.inc is compilable
+
+  Revision 1.13  1998/01/18 21:34:29  florian
+  *** empty log message ***
+
+  Revision 1.12  1998/01/16 12:52:10  michael
+  + Path treatment and file searching should now be more or less in their
+    definite form:
+    - Using now modified AddPathToList everywhere.
+    - File Searching mechanism is uniform for all files.
+    - Include path is working now !!
+    All fixes by Peter Vreman. Tested with remake3 target.
+
+  Revision 1.11  1998/01/07 00:17:04  michael
+  Restored released version (plus fixes) as current
+
+  Revision 1.10  1997/12/12 13:28:39  florian
+  + version 0.99.0
+  * all WASM options changed into MASM
+  + -O2 for Pentium II optimizations
+
+  Revision 1.9  1997/12/09 13:57:21  carl
+  * bugfix when compiling using overlays
+
+  Revision 1.8  1997/12/05 14:38:39  carl
+  * equivalent to version 1.5 (otherwise would not compile)
+
+  Revision 1.5  1997/12/03 14:36:14  carl
+  * bugfix of my bug with $ifdef support_mxx
+
+  Revision 1.4  1997/12/03 13:41:37  carl
+   + checks that i386 is defined if with mmx_support switch.
+
+  Revision 1.3  1997/11/29 15:40:10  florian
+  + myexit is now executed
+
+  Revision 1.2  1997/11/28 18:14:43  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:
+
+  FK     Florian Klaempfl
+  +      feature added
+  -      removed
+  *      bug fixed or changed
+
+  History (started at 19th september 1997):
+      19th september 1997:
+       + informations about ccompiler switches added (FK)
+       2nd october 1997:
+         *- removed ifndef dpmi for stream init, tmemorystream is used if
+          in dpmi everywhere else if use_big on. (CEC)
+       6th november 1997:
+         - crt unit to allow output redirection (FK)
+}

compiler/ppovin.pas

@@ -0,0 +1,73 @@
+{
+    $Id$
+    Copyright (c) 1997-98 by Daniel Mantione
+
+    Handles the overlay initialisation for a TP7 compiled version
+
+    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 ppovin;
+
+interface
+
+var ovrminsize:longint;
+
+implementation
+
+uses    overlay;
+
+var s:string;
+
+begin
+    s:=paramstr(0);
+    ovrinit(copy(s,1,length(s)-3)+'ovr');
+    if ovrresult=ovrok then
+        begin
+            {May fail if no EMS memory is available. No need for error
+             checking, though, as the overlay manager happily runs without
+             EMS.}
+            ovrinitEMS;
+            ovrminsize:=ovrgetbuf;
+            ovrsetbuf(ovrminsize+$20000);
+        end
+    else
+        runerror($da);
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.5  1998/03/10 01:17:24  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+
+  Pre CVS Log:
+
+  FK     Florian Klaempfl
+  DM     Dani‰l Mantione
+  +      feature added
+  -      removed
+  *      bug fixed or changed
+
+  12th October 1997:
+        Rewritten (DM).
+}
+
+

compiler/pstatmnt.pas

@@ -0,0 +1,1154 @@
+{
+    $Id$
+    Copyright (c) 1998 by Florian Klaempfl
+
+    Does the parsing of the statements
+
+    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 pstatmnt;
+
+  interface
+
+    uses tree;
+
+    var
+       { true, if we are in a except block }
+       in_except_block : boolean;
+
+    { reads a block }
+    function block(islibrary : boolean) : ptree;
+
+    { reads an assembler block }
+    function assembler_block : ptree;
+
+  implementation
+
+    uses
+       cobjects,scanner,globals,symtable,aasm,pass_1,
+       types,hcodegen,files,verbose
+       { processor specific stuff }
+{$ifdef i386}
+       ,i386
+       ,rai386
+       ,ratti386
+       ,radi386
+       ,tgeni386
+{$endif}
+{$ifdef m68k}
+       ,m68k
+       ,tgen68k
+       ,ag68kmit
+       ,ra68k
+       ,ag68kgas
+       ,ag68kmot
+{$endif}
+       { parser specific stuff, be careful consume is also defined to }
+       { read assembler tokens                                        }
+       ,pbase,pexpr,pdecl;
+
+
+    function statement : ptree;forward;
+
+    function if_statement : ptree;
+
+      var
+         ex,if_a,else_a : ptree;
+
+      begin
+         consume(_IF);
+         ex:=expr;
+         consume(_THEN);
+         if token<>_ELSE then
+           if_a:=statement
+         else
+       if_a:=nil;
+
+         if token=_ELSE then
+           begin
+              consume(_ELSE);
+              else_a:=statement;
+           end
+         else
+           else_a:=nil;
+         if_statement:=genloopnode(ifn,ex,if_a,else_a,false);
+      end;
+
+    { creates a block (list) of statements, til the next END token }
+    function statements_til_end : ptree;
+
+      var
+         first,last : ptree;
+
+      begin
+         first:=nil;
+         while token<>_END do
+           begin
+              if first=nil then
+                begin
+                   last:=gennode(anwein,nil,statement);
+                   first:=last;
+                end
+              else
+                begin
+                   last^.left:=gennode(anwein,nil,statement);
+                   last:=last^.left;
+                end;
+              if token<>SEMICOLON then
+                break
+              else
+                consume(SEMICOLON);
+              while token=SEMICOLON do
+                consume(SEMICOLON);
+
+           end;
+         consume(_END);
+         statements_til_end:=gensinglenode(blockn,first);
+      end;
+
+    function case_statement : ptree;
+
+      var
+         { contains the label number of currently parsed case block }
+         aktcaselabel : plabel;
+         wurzel : pcaserecord;
+
+         { the typ of the case expression }
+         casedef : pdef;
+
+      procedure newcaselabel(l,h : longint);
+
+        var
+           hcaselabel : pcaserecord;
+
+        procedure insertlabel(var p : pcaserecord);
+
+          begin
+             if p=nil then p:=hcaselabel
+             else
+                if (p^._low>hcaselabel^._low) and
+                   (p^._low>hcaselabel^._high) then
+                  insertlabel(p^.less)
+                else if (p^._high<hcaselabel^._low) and
+                   (p^._high<hcaselabel^._high) then
+                  insertlabel(p^.greater)
+                else Message(parser_e_double_caselabel);
+          end;
+
+        begin
+           new(hcaselabel);
+           hcaselabel^.less:=nil;
+           hcaselabel^.greater:=nil;
+           hcaselabel^.statement:=aktcaselabel;
+           getlabel(hcaselabel^._at);
+           hcaselabel^._low:=l;
+           hcaselabel^._high:=h;
+           insertlabel(wurzel);
+        end;
+
+      var
+         code,caseexpr,p,instruc,elseblock : ptree;
+         hl1,hl2 : longint;
+         ranges : boolean;
+
+      begin
+         consume(_CASE);
+         caseexpr:=expr;
+         { determines result type }
+         cleartempgen;
+         do_firstpass(caseexpr);
+         casedef:=caseexpr^.resulttype;
+
+         if not(is_ordinal(casedef)) then
+           Message(parser_e_ordinal_expected);
+
+         consume(_OF);
+         wurzel:=nil;
+         ranges:=false;
+         instruc:=nil;
+         repeat
+           getlabel(aktcaselabel);
+           {aktcaselabel^.is_used:=true; }
+
+           { an instruction has may be more case labels }
+           repeat
+             p:=expr;
+             cleartempgen;
+             do_firstpass(p);
+
+             if (p^.treetype=rangen) then
+               begin
+                  { type checking for case statements }
+                  if not is_subequal(casedef, p^.left^.resulttype) then
+                    Message(parser_e_case_mismatch);
+                  { type checking for case statements }
+                  if not is_subequal(casedef, p^.right^.resulttype) then
+                    Message(parser_e_case_mismatch);
+                  hl1:=get_ordinal_value(p^.left);
+                  hl2:=get_ordinal_value(p^.right);
+                  testrange(casedef,hl1);
+                  testrange(casedef,hl2);
+                  newcaselabel(hl1,hl2);
+                  ranges:=true;
+               end
+             else
+               begin
+                  { type checking for case statements }
+                  if not is_subequal(casedef, p^.resulttype) then
+                    Message(parser_e_case_mismatch);
+                    hl1:=get_ordinal_value(p);
+                    testrange(casedef,hl1);
+                    newcaselabel(hl1,hl1);
+               end;
+             disposetree(p);
+             if token=COMMA then consume(COMMA)
+               else break;
+           until false;
+           consume(COLON);
+
+           { handles instruction block }
+           p:=gensinglenode(labeln,statement);
+           p^.labelnr:=aktcaselabel;
+
+           { concats instruction }
+           instruc:=gennode(anwein,instruc,p);
+
+           if not((token=_ELSE) or (token=_OTHERWISE) or (token=_END)) then
+             consume(SEMICOLON);
+         until (token=_ELSE) or (token=_OTHERWISE) or (token=_END);
+
+         if (token=_ELSE) or (token=_OTHERWISE) then
+           begin
+              if token=_ELSE then consume(_ELSE)
+                else consume(_OTHERWISE);
+              elseblock:=statements_til_end;
+           end
+         else
+           begin
+              elseblock:=nil;
+              consume(_END);
+           end;
+
+         code:=gencasenode(caseexpr,instruc,wurzel);
+
+         code^.elseblock:=elseblock;
+
+         case_statement:=code;
+      end;
+
+    function repeat_statement : ptree;
+
+      var
+         first,last,p_e : ptree;
+
+      begin
+         consume(_REPEAT);
+         first:=nil;
+         while token<>_UNTIL do
+           begin
+              if first=nil then
+                begin
+                   last:=gennode(anwein,nil,statement);
+                   first:=last;
+                end
+              else
+                begin
+                   last^.left:=gennode(anwein,nil,statement);
+                   last:=last^.left;
+                end;
+              if token<>SEMICOLON then
+                break;
+              consume(SEMICOLON);
+              while token=SEMICOLON do
+                consume(SEMICOLON);
+           end;
+         consume(_UNTIL);
+         first:=gensinglenode(blockn,first);
+         p_e:=expr;
+         repeat_statement:=genloopnode(repeatn,p_e,first,nil,false);
+      end;
+
+    function while_statement : ptree;
+
+      var
+         p_e,p_a : ptree;
+
+      begin
+         consume(_WHILE);
+     p_e:=expr;
+         consume(_DO);
+         p_a:=statement;
+         while_statement:=genloopnode(whilen,p_e,p_a,nil,false);
+      end;
+
+    function for_statement : ptree;
+
+      var
+         p_e,tovalue,p_a : ptree;
+         backward : boolean;
+
+      begin
+         { parse loop header }
+         consume(_FOR);
+         p_e:=expr;
+         if token=_DOWNTO then
+           begin
+              consume(_DOWNTO);
+              backward:=true;
+           end
+         else
+           begin
+              consume(_TO);
+              backward:=false;
+           end;
+         tovalue:=expr;
+         consume(_DO);
+
+         { ... now the instruction }
+                 p_a:=statement;
+                 for_statement:=genloopnode(forn,p_e,tovalue,p_a,backward);
+          end;
+
+    function _with_statement : ptree;
+
+      var
+         right,hp,p : ptree;
+         i,levelcount : longint;
+         withsymtable,symtab : psymtable;
+         obj : pobjectdef;
+
+      begin
+         Must_be_valid:=false;
+         p:=expr;
+         do_firstpass(p);
+         right:=nil;
+         case p^.resulttype^.deftype of
+            objectdef : begin
+                          obj:=pobjectdef(p^.resulttype);
+                          levelcount:=0;
+                          while assigned(obj) do
+                            begin
+                               symtab:=obj^.publicsyms;
+                               withsymtable:=new(psymtable,init(symtable.withsymtable));
+                               withsymtable^.wurzel:=symtab^.wurzel;
+                               withsymtable^.next:=symtablestack;
+                               symtablestack:=withsymtable;
+                               obj:=obj^.childof;
+                               inc(levelcount);
+                            end;
+                       end;
+            recorddef : begin
+                           symtab:=precdef(p^.resulttype)^.symtable;
+                           levelcount:=1;
+                           withsymtable:=new(psymtable,init(symtable.withsymtable));
+                           withsymtable^.wurzel:=symtab^.wurzel;
+                           withsymtable^.next:=symtablestack;
+                           symtablestack:=withsymtable;
+                        end;
+            else
+              begin
+                    Message(parser_e_false_with_expr);
+                    { try to recover from error }
+                    if token=COMMA then
+                      begin
+                         consume(COMMA);
+{$ifdef tp}
+                                                 hp:=_with_statement;
+{$else}
+                                                 hp:=_with_statement();
+{$endif}
+                                          end
+                                        else
+                                          begin
+                                                 consume(_DO);
+                                                 { ignore all }
+                                                 if token<>SEMICOLON then
+                                                   statement;
+                      end;
+                    _with_statement:=nil;
+                    exit;
+                 end;
+         end;
+         if token=COMMA then
+           begin
+              consume(COMMA);
+{$ifdef tp}
+                          right:=_with_statement;
+{$else}
+              right:=_with_statement();
+{$endif}
+           end
+         else
+           begin
+              consume(_DO);
+              if token<>SEMICOLON then
+                right:=statement
+              else
+                right:=nil;
+           end;
+         for i:=1 to levelcount do
+           symtablestack:=symtablestack^.next;
+
+         _with_statement:=genwithnode(withsymtable,p,right,levelcount);
+      end;
+
+    function with_statement : ptree;
+
+      begin
+         consume(_WITH);
+         with_statement:=_with_statement;
+      end;
+
+    function raise_statement : ptree;
+
+      var
+         p1,p2 : ptree;
+
+      begin
+         p1:=nil;
+         p2:=nil;
+         consume(_RAISE);
+         if token<>SEMICOLON then
+           begin
+              p1:=expr;
+              if (token=ID) and (pattern='AT') then
+                begin
+                   consume(ID);
+                   p2:=expr;
+                end;
+           end
+         else
+           begin
+              if not(in_except_block) then
+               Message(parser_e_no_reraise_possible);
+           end;
+         raise_statement:=gennode(raisen,p1,p2);
+      end;
+
+    function try_statement : ptree;
+
+      var
+         p_try_block,p_finally_block,first,last,
+         p_default,e1,e2,p_specific : ptree;
+
+         old_in_except_block : boolean;
+
+      begin
+         p_default:=nil;
+         p_specific:=nil;
+
+         { read statements to try }
+         consume(_TRY);
+         first:=nil;
+         while (token<>_FINALLY) and (token<>_EXCEPT) do
+                   begin
+              if first=nil then
+                begin
+                                   last:=gennode(anwein,nil,statement);
+                   first:=last;
+                end
+              else
+                begin
+                                   last^.left:=gennode(anwein,nil,statement);
+                   last:=last^.left;
+                end;
+                          if token<>SEMICOLON then
+                                break;
+                          consume(SEMICOLON);
+                          emptystats;
+                   end;
+         p_try_block:=gensinglenode(blockn,first);
+
+         if token=_FINALLY then
+           begin
+              consume(_FINALLY);
+              p_finally_block:=statements_til_end;
+              try_statement:=gennode(tryfinallyn,p_try_block,p_finally_block);
+           end
+         else
+           begin
+              consume(_EXCEPT);
+              old_in_except_block:=in_except_block;
+              in_except_block:=true;
+
+              if token=_ON then
+                { catch specific exceptions }
+                begin
+                   repeat
+                     consume(_ON);
+             e1:=expr;
+                     if token=COLON then
+                       begin
+                          consume(COLON);
+              e2:=expr;
+                          { !!!!! }
+                       end
+                     else
+                       begin
+                          { !!!!! }
+                       end;
+                     consume(_DO);
+                                         statement;
+                                         if token<>SEMICOLON then
+                                           break;
+                                         emptystats;
+                                   until false;
+                   if token=_ELSE then
+                     { catch the other exceptions }
+                     begin
+                        consume(_ELSE);
+                        p_default:=statements_til_end;
+                     end;
+                end
+              else
+                { catch all exceptions }
+                begin
+                   p_default:=statements_til_end;
+                end;
+              in_except_block:=old_in_except_block;
+              try_statement:=genloopnode(tryexceptn,p_try_block,p_specific,p_default,false);
+           end;
+      end;
+
+    function exit_statement : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         consume(_EXIT);
+         if token=LKLAMMER then
+           begin
+              consume(LKLAMMER);
+          p:=expr;
+              consume(RKLAMMER);
+              if procinfo.retdef=pdef(voiddef) then
+                Message(parser_e_void_function);
+           end
+         else
+           p:=nil;
+         exit_statement:=gensinglenode(exitn,p);
+      end;
+
+
+{$ifdef i386}
+    function _asm_statement : ptree;
+
+      begin
+         case aktasmmode of
+            I386_ATT : _asm_statement:=ratti386.assemble;
+            I386_INTEL : _asm_statement:=rai386.assemble;
+            I386_DIRECT : _asm_statement:=radi386.assemble;
+            else internalerror(30004);
+         end;
+
+         { Erst am Ende _ASM konsumieren, da der Scanner sonst die }
+         { erste Assemblerstatement zu lesen versucht! }
+         consume(_ASM);
+
+         { (END is read) }
+         if token=LECKKLAMMER then
+           begin
+              { it's possible to specify the modified registers }
+              consume(LECKKLAMMER);
+              if token<>RECKKLAMMER then
+                repeat
+                  pattern:=upper(pattern);
+                  if pattern='EAX' then
+                    usedinproc:=usedinproc or ($80 shr byte(R_EAX))
+                  else if pattern='EBX' then
+                    usedinproc:=usedinproc or ($80 shr byte(R_EBX))
+                  else if pattern='ECX' then
+                    usedinproc:=usedinproc or ($80 shr byte(R_ECX))
+                  else if pattern='EDX' then
+                    usedinproc:=usedinproc or ($80 shr byte(R_EDX))
+                  else if pattern='ESI' then
+                    usedinproc:=usedinproc or ($80 shr byte(R_ESI))
+                  else if pattern='EDI' then
+                    usedinproc:=usedinproc or ($80 shr byte(R_EDI))
+                  else consume(RECKKLAMMER);
+                  consume(CSTRING);
+                  if token=COMMA then consume(COMMA)
+                    else break;
+                until false;
+              consume(RECKKLAMMER);
+           end
+         else usedinproc:=$ff;
+      end;
+{$endif}
+
+{$ifdef m68k}
+    function _asm_statement : ptree;
+    begin
+         _asm_statement:= ra68k.assemble;
+         { Erst am Ende _ASM konsumieren, da der Scanner sonst die }
+         { erste Assemblerstatement zu lesen versucht! }
+         consume(_ASM);
+
+         { (END is read) }
+         if token=LECKKLAMMER then
+           begin
+              { it's possible to specify the modified registers }
+              { we only check the registers which are not reserved }
+              { and which can be used. This is done for future     }
+              { optimizations.                                     }
+              consume(LECKKLAMMER);
+              if token<>RECKKLAMMER then
+                repeat
+                  pattern:=upper(pattern);
+                  if pattern='D0' then
+                    usedinproc:=usedinproc or ($800 shr word(R_D0))
+                  else if pattern='D1' then
+                    usedinproc:=usedinproc or ($800 shr word(R_D1))
+                  else if pattern='D6' then
+                    usedinproc:=usedinproc or ($800 shr word(R_D6))
+                  else if pattern='A0' then
+                    usedinproc:=usedinproc or ($800 shr word(R_A0))
+                  else if pattern='A1' then
+                    usedinproc:=usedinproc or ($800 shr word(R_A1))
+                  else consume(RECKKLAMMER);
+                  consume(CSTRING);
+                  if token=COMMA then consume(COMMA)
+                    else break;
+                until false;
+              consume(RECKKLAMMER);
+           end
+         else usedinproc:=$ffff;
+    end;
+{$endif}
+
+
+        function new_dispose_statement : ptree;
+
+          var
+                 p,p2 : ptree;
+                 ht : ttoken;
+         again : boolean; { dummy for do_proc_call }
+                 destrukname : stringid;
+                 sym : psym;
+                 classh : pobjectdef;
+                 pd,pd2 : pdef;
+                 store_valid : boolean;
+                 tt : ttreetyp;
+
+          begin
+                 ht:=token;
+                 if token=_NEW then consume(_NEW)
+                   else consume(_DISPOSE);
+                 if ht=_NEW then
+                   tt:=hnewn
+                 else
+                   tt:=hdisposen;
+                 consume(LKLAMMER);
+                 p:=expr;
+
+                 { calc return type }
+                 cleartempgen;
+                 Store_valid := Must_be_valid;
+                 Must_be_valid := False;
+                 do_firstpass(p);
+                 Must_be_valid := Store_valid;
+
+         {var o:Pobject;
+
+                  begin
+                      new(o,init);        (*Also a valid new statement*)
+                  end;}
+
+                 if token=COMMA then
+                   begin
+                          { extended syntax of new and dispose }
+                          { function styled new is handled in factor }
+                          consume(COMMA);
+                          { destructors have no parameters }
+                          destrukname:=pattern;
+                          consume(ID);
+
+                          pd:=p^.resulttype;
+                          pd2:=pd;
+                          if (p^.resulttype = nil) or (pd^.deftype<>pointerdef) then
+                            begin
+                               Message(parser_e_pointer_type_expected);
+                               p:=factor(false);
+                               consume(RKLAMMER);
+                               new_dispose_statement:=genzeronode(errorn);
+                               exit;
+                            end;
+                          { first parameter must be an object or class }
+                          if ppointerdef(pd)^.definition^.deftype<>objectdef then
+                            begin
+                               Message(parser_e_pointer_to_class_expected);
+                               new_dispose_statement:=factor(false);
+                               consume_all_until(RKLAMMER);
+                               consume(RKLAMMER);
+                               exit;
+                            end;
+                          { check, if the first parameter is a pointer to a _class_ }
+                          classh:=pobjectdef(ppointerdef(pd)^.definition);
+                          if (classh^.options and oois_class)<>0 then
+                                begin
+                                   Message(parser_e_no_new_or_dispose_for_classes);
+                                   new_dispose_statement:=factor(false);
+                                   { while token<>RKLAMMER do
+                                         consume(token); }
+                                   consume_all_until(RKLAMMER);
+                                   consume(RKLAMMER);
+                                   exit;
+                                end;
+                          { search cons-/destructor, also in parent classes }
+                          sym:=nil;
+                          while assigned(classh) do
+                                begin
+                                   sym:=classh^.publicsyms^.search(pattern);
+                                   srsymtable:=classh^.publicsyms;
+                                   if assigned(sym) then
+                                         break;
+                                   classh:=classh^.childof;
+                                end;
+                          { the second parameter of new/dispose must be a call }
+                          { to a cons-/destructor                                }
+                          if (sym^.typ<>procsym) then
+                                begin
+                                   Message(parser_e_expr_have_to_be_destructor_call);
+                                   new_dispose_statement:=genzeronode(errorn);
+                                end
+                          else
+                                begin
+                                  p2:=gensinglenode(tt,p);
+                                  if ht=_NEW then
+                                        begin
+                                           { Constructors can take parameters.}
+                                           p2^.resulttype:=ppointerdef(pd)^.definition;
+                                           do_member_read(sym,p2,pd,again);
+                                        end
+                                  else
+                                    { destructors can't.}
+                                    p2:=genmethodcallnode(pprocsym(sym),srsymtable,p2);
+
+                                  { we need the real called method }
+                                  cleartempgen;
+                                  do_firstpass(p2);
+
+                                  if (ht=_NEW) and ((p2^.procdefinition^.options and poconstructor)=0) then
+                                         Message(parser_e_expr_have_to_be_constructor_call);
+                                  if (ht=_DISPOSE) and ((p2^.procdefinition^.options and podestructor)=0) then
+                                         Message(parser_e_expr_have_to_be_destructor_call);
+
+                                  if ht=_NEW then
+                                        begin
+                                                p2:=gennode(assignn,getcopy(p),gensinglenode(newn,p2));
+                                                p2^.right^.resulttype:=pd2;
+                                        end;
+                                  new_dispose_statement:=p2;
+                                end;
+                   end
+                 else
+                   begin
+                      if (p^.resulttype=nil) or (p^.resulttype^.deftype<>pointerdef) then
+                        Begin
+                           Message(parser_e_pointer_type_expected);
+                           new_dispose_statement:=genzeronode(errorn);
+                        end
+                      else
+                        begin
+                           if (ppointerdef(p^.resulttype)^.definition^.deftype=objectdef) then
+                            Message(parser_w_use_extended_syntax_for_objects);
+
+                            case ht of
+                               _NEW : new_dispose_statement:=gensinglenode(simplenewn,p);
+                               _DISPOSE : new_dispose_statement:=gensinglenode(simpledisposen,p);
+                            end;
+                        end;
+                   end;
+                 consume(RKLAMMER);
+          end;
+
+    function statement_block : ptree;
+
+      var
+         first,last : ptree;
+
+      begin
+         first:=nil;
+         consume(_BEGIN);
+         while token<>_END do
+           begin
+              if first=nil then
+                begin
+                   last:=gennode(anwein,nil,statement);
+                   first:=last;
+                end
+              else
+                begin
+                   last^.left:=gennode(anwein,nil,statement);
+                   last:=last^.left;
+                end;
+              if token=_END then
+                break
+              else
+                begin
+                   { if no semicolon, then error and go on }
+                   if token<>SEMICOLON then
+                     begin
+                        consume(SEMICOLON);
+                        { while token<>SEMICOLON do
+                          consume(token); }
+                        consume_all_until(SEMICOLON);
+                     end;
+                   consume(SEMICOLON);
+                end;
+              emptystats;
+           end;
+         consume(_END);
+         first:=gensinglenode(blockn,first);
+         statement_block:=first;
+      end;
+
+    function statement : ptree;
+
+      var
+         p : ptree;
+         code : ptree;
+         labelnr : plabel;
+
+      label
+         ready;
+
+      begin
+         case token of
+            _GOTO : begin
+                       if not(cs_support_goto in aktswitches)then
+                        Message(sym_e_goto_and_label_not_supported);
+                       consume(_GOTO);
+                       if (token<>INTCONST) and (token<>ID) then
+                         begin
+                            Message(sym_e_label_not_found);
+                            code:=genzeronode(errorn);
+                         end
+                       else
+                         begin
+                            getsym(pattern,true);
+                            consume(token);
+                            if srsym^.typ<>labelsym then
+                              begin
+                                 Message(sym_e_id_is_no_label_id);
+                                 code:=genzeronode(errorn);
+                              end
+                            else
+                              code:=genlabelnode(goton,
+                                plabelsym(srsym)^.number);
+                         end;
+                    end;
+            _BEGIN : code:=statement_block;
+            _IF    : code:=if_statement;
+            _CASE  : code:=case_statement;
+            _REPEAT : code:=repeat_statement;
+            _WHILE : code:=while_statement;
+            _FOR : code:=for_statement;
+            _NEW,_DISPOSE : code:=new_dispose_statement;
+
+            _WITH : code:=with_statement;
+            _TRY : code:=try_statement;
+            _RAISE : code:=raise_statement;
+            { semicolons,else until and end are ignored }
+            SEMICOLON,
+            _ELSE,
+            _UNTIL,
+            _END : code:=genzeronode(niln);
+            _CONTINUE : begin
+                           consume(_CONTINUE);
+                           code:=genzeronode(continuen);
+                        end;
+            _FAIL : begin
+                       { internalerror(100); }
+                       if (aktprocsym^.definition^.options and poconstructor)=0 then
+                        Message(parser_e_fail_only_in_constructor);
+                       consume(_FAIL);
+                       code:=genzeronode(failn);
+                    end;
+            _BREAK:
+           begin
+                  consume(_BREAK);
+                  code:=genzeronode(breakn);
+               end;
+                        _EXIT : code:=exit_statement;
+                        _ASM : code:=_asm_statement;
+                        else
+                           begin
+                                  if (token=INTCONST) or
+                    ((token=ID) and
+                      not((cs_delphi2_compatible in aktswitches) and
+                        (pattern='RESULT'))) then
+                                        begin
+                                           getsym(pattern,true);
+                                           if srsym^.typ=labelsym then
+                                                 begin
+                                                        consume(token);
+                                                        consume(COLON);
+                                                        if plabelsym(srsym)^.defined then
+                                                          Message(sym_e_label_already_defined);
+                                                        plabelsym(srsym)^.defined:=true;
+
+                                                        { statement modifies srsym }
+                                                        labelnr:=plabelsym(srsym)^.number;
+
+                                                        { the pointer to the following instruction }
+                                                        { isn't a very clean way                   }
+{$ifdef tp}
+                                                        code:=gensinglenode(labeln,statement);
+{$else}
+                                                        code:=gensinglenode(labeln,statement());
+{$endif}
+                                                        code^.labelnr:=labelnr;
+                                                        { sorry, but there is a jump the easiest way }
+                                                        goto ready;
+                                                 end;
+                                        end;
+                  p:=expr;
+                                  if (aktexprlevel<9) and (p^.treetype<>calln)
+                                    and (p^.treetype<>assignn) and (p^.treetype<>inlinen) then
+                                    Message(cg_e_illegal_expression);
+                                  code:=p;
+                           end;
+                 end;
+          ready:
+                 statement:=code;
+          end;
+
+    function block(islibrary : boolean) : ptree;
+
+{$ifdef TEST_FUNCRET }
+      var
+         funcretsym : pfuncretsym;
+{$endif TEST_FUNCRET }
+
+      begin
+{$ifdef TEST_FUNCRET }
+         if procinfo.retdef<>pdef(voiddef) then
+           begin
+              { if the current is a function aktprocsym is non nil }
+              { and there is a local symtable set }
+              funcretsym:=new(pfuncretsym,init(aktprocsym^.name),@procinfo);
+              { insert in local symtable }
+              symtablestack^.insert(funcretsym);
+           end;
+{$endif TEST_FUNCRET }
+         read_declarations(islibrary);
+
+         { temporary space is set, while the BEGIN of the procedure }
+         if (symtablestack^.symtabletype=localsymtable) then
+           procinfo.firsttemp := -symtablestack^.datasize
+         else procinfo.firsttemp := 0;
+
+         { space for the return value }
+         { !!!!!   this means that we can not set the return value
+         in a subfunction !!!!! }
+         { because we don't know yet where the address is }
+         if procinfo.retdef<>pdef(voiddef) then
+           begin
+              if ret_in_acc(procinfo.retdef) or (procinfo.retdef^.deftype=floatdef) then
+              { if (procinfo.retdef^.deftype=orddef) or
+                 (procinfo.retdef^.deftype=pointerdef) or
+                 (procinfo.retdef^.deftype=enumdef) or
+                 (procinfo.retdef^.deftype=procvardef) or
+                 (procinfo.retdef^.deftype=floatdef) or
+                 (
+                   (procinfo.retdef^.deftype=setdef) and
+                   (psetdef(procinfo.retdef)^.settype=smallset)
+                 ) then  }
+                begin
+{$ifdef TEST_FUNCRET }
+                   { the space has been set in the local symtable }
+                   procinfo.retoffset:=-funcretsym^.address;
+                   strdispose(funcretsym^._name);
+                   { lowercase name unreachable }
+                   { as it is handled differently }
+                   funcretsym^._name:=strpnew('func_result');
+{$else  TEST_FUNCRET }
+                   procinfo.retoffset:=procinfo.firsttemp-procinfo.retdef^.size;
+                   procinfo.firsttemp:=procinfo.retoffset;
+{$endif TEST_FUNCRET }
+                   if (procinfo.flags and pooperator)<>0 then
+                     {opsym^.address:=procinfo.call_offset; is wrong PM }
+                     opsym^.address:=procinfo.retoffset;
+                   { eax is modified by a function }
+{$ifdef i386}
+                   usedinproc:=usedinproc or ($80 shr byte(R_EAX))
+{$endif}
+{$ifdef m68k}
+                   usedinproc:=usedinproc or ($800 shr word(R_D0))
+{$endif}
+                end;
+           end;
+
+         {Unit initialization?.}
+         if (lexlevel=1) then
+            if (token=_END) then
+                begin
+                    consume(_END);
+                    block:=nil;
+                end
+            else
+                begin
+                    current_module^.flags:=current_module^.flags or
+                     uf_init;
+                    block:=statement_block;
+                end
+         else
+            block:=statement_block;
+      end;
+
+    function assembler_block : ptree;
+
+      begin
+         read_declarations(false);
+         { temporary space is set, while the BEGIN of the procedure }
+         if symtablestack^.symtabletype=localsymtable then
+           procinfo.firsttemp := -symtablestack^.datasize
+         else procinfo.firsttemp := 0;
+
+         { assembler code does not allocate }
+         { space for the return value       }
+          if procinfo.retdef<>pdef(voiddef) then
+           begin
+              if ret_in_acc(procinfo.retdef) then
+                begin
+                   { in assembler code the result should be directly in %eax
+                   procinfo.retoffset:=procinfo.firsttemp-procinfo.retdef^.size;
+                   procinfo.firsttemp:=procinfo.retoffset;                   }
+
+{$ifdef i386}
+                   usedinproc:=usedinproc or ($80 shr byte(R_EAX))
+{$endif}
+{$ifdef m68k}
+                   usedinproc:=usedinproc or ($800 shr word(R_D0))
+{$endif}
+                end
+              else
+              { should we allow assembler functions of big elements ? }
+               Message(parser_e_asm_incomp_with_function_return);
+           end;
+           { set the framepointer to esp for assembler functions }
+           { but only if the are no local variables              }
+           if ((aktprocsym^.definition^.options and poassembler)<>0) and
+               (aktprocsym^.definition^.localst^.datasize=0) then
+               begin
+{$ifdef i386}
+                  procinfo.framepointer:=R_ESP;
+{$endif}
+{$ifdef m68k}
+                  procinfo.framepointer:=R_SP;
+{$endif}
+                  { set the right value for parameters }
+                  dec(aktprocsym^.definition^.parast^.call_offset,4);
+                  dec(procinfo.call_offset,4);
+              end;
+            assembler_block:=_asm_statement;
+          end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.21  1998/03/10 16:27:42  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 04:18:26  carl
+   * wrong units were being used with m68k target
+
+  Revision 1.19  1998/03/10 01:17:25  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.18  1998/03/06 00:52:46  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.17  1998/03/02 01:49:07  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.16  1998/02/22 23:03:30  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.15  1998/02/21 03:33:54  carl
+    + mit assembler syntax support
+
+  Revision 1.14  1998/02/13 10:35:29  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.13  1998/02/12 11:50:30  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.12  1998/02/11 21:56:39  florian
+    * bugfixes: bug0093, bug0053, bug0088, bug0087, bug0089
+
+  Revision 1.11  1998/02/07 09:39:26  florian
+    * correct handling of in_main
+    + $D,$T,$X,$V like tp
+
+  Revision 1.10  1998/01/31 00:42:26  carl
+    +* Final bugfix #60 (working!) Type checking in case statements
+
+  Revision 1.7  1998/01/21 02:18:28  carl
+    * bugfix 79 (assembler_block now chooses the correct framepointer and
+      offset).
+
+  Revision 1.6  1998/01/16 22:34:43  michael
+  * Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
+    in this compiler :)
+
+  Revision 1.5  1998/01/12 14:51:18  carl
+    - temporariliy removed case type checking until i know where the bug
+      comes from!
+
+  Revision 1.4  1998/01/11 19:23:49  carl
+    * bug fix number 60 (case statements type checking)
+
+  Revision 1.3  1998/01/11 10:54:25  florian
+    + generic library support
+
+  Revision 1.2  1998/01/09 09:10:02  michael
+  + Initial implementation, second try
+
+}

compiler/ptconst.pas

@@ -0,0 +1,506 @@
+{
+    $Id$
+    Copyright (c) 1998 by Florian Klaempfl
+
+    Reads typed constants
+
+    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 ptconst;
+
+  interface
+
+   uses symtable;
+
+    { this procedure reads typed constants }
+    procedure readtypedconst(def : pdef);
+
+  implementation
+
+    uses
+       cobjects,globals,scanner,aasm,tree,pass_1,
+       hcodegen,types,verbose
+       { parser specific stuff }
+       ,pbase,pexpr
+       { processor specific stuff }
+{$ifdef i386}
+       ,i386
+{$endif}
+{$ifdef m68k}
+       ,m68k
+{$endif}
+       ;
+
+    { this procedure reads typed constants }
+    procedure readtypedconst(def : pdef);
+
+      var
+         p : ptree;
+         i,l : longint;
+         ll : plabel;
+         s : string;
+         ca : pchar;
+         aktpos : longint;
+         pd : pprocdef;
+         hp1,hp2 : pdefcoll;
+
+         value : bestreal;
+         {problem with fldt !!
+         anyway .valued is not extended !!
+         value : double; }
+
+      procedure check_range;
+
+        begin
+           if ((p^.value>porddef(def)^.bis) or
+               (p^.value<porddef(def)^.von)) then
+             Message(parser_e_range_check_error);
+        end;
+
+{$R-}  {Range check creates problem with init_8bit(-1) !!}
+      begin
+         case def^.deftype of
+            orddef:
+              begin
+                 p:=expr;
+                 do_firstpass(p);
+                 case porddef(def)^.typ of
+                    s8bit,
+                    u8bit : begin
+                               if not is_constintnode(p) then
+                               { is't an int expected }
+                                 Message(cg_e_illegal_expression)
+                               else
+                                 begin
+                                    datasegment^.concat(new(pai_const,init_8bit(p^.value)));
+                                    check_range;
+                                 end;
+                            end;
+                    s32bit : begin
+                                if not is_constintnode(p) then
+                                  Message(cg_e_illegal_expression)
+                                else
+                                  begin
+                                     datasegment^.concat(new(pai_const,init_32bit(p^.value)));
+                                     check_range;
+                                  end;
+                            end;
+                    u32bit : begin
+                                if not is_constintnode(p) then
+                                  Message(cg_e_illegal_expression)
+                                else
+                                   datasegment^.concat(new(pai_const,init_32bit(p^.value)));
+                             end;
+                    bool8bit : begin
+                                  if not is_constboolnode(p) then
+                                    Message(cg_e_illegal_expression);
+                                  datasegment^.concat(new(pai_const,init_8bit(p^.value)));
+                               end;
+                    uchar : begin
+                                if not is_constcharnode(p) then
+                                  Message(cg_e_illegal_expression);
+                                datasegment^.concat(new(pai_const,init_8bit(p^.value)));
+                            end;
+                    u16bit,
+                    s16bit : begin
+                                if not is_constintnode(p) then
+                                  Message(cg_e_illegal_expression);
+                                datasegment^.concat(new(pai_const,init_16bit(p^.value)));
+                                check_range;
+                            end;
+                 end;
+                 disposetree(p);
+              end;
+         floatdef:
+           begin
+              p:=expr;
+              do_firstpass(p);
+              if is_constrealnode(p) then
+                value:=p^.valued
+              else if is_constintnode(p) then
+                value:=p^.value
+              else
+                Message(cg_e_illegal_expression);
+
+              case pfloatdef(def)^.typ of
+                 s64real : datasegment^.concat(new(pai_double,init(value)));
+                 s32real : datasegment^.concat(new(pai_single,init(value)));
+                 s80real : datasegment^.concat(new(pai_extended,init(value)));
+                 s64bit  : datasegment^.concat(new(pai_comp,init(value)));
+                 f32bit : datasegment^.concat(new(pai_const,init_32bit(trunc(value*65536))));
+              else internalerror(18);
+              end;
+              disposetree(p);
+           end;
+         pointerdef:
+           begin
+              p:=expr;
+              do_firstpass(p);
+              { nil pointer ? }
+              if p^.treetype=niln then
+                datasegment^.concat(new(pai_const,init_32bit(0)))
+              { maybe pchar ? }
+              else if (ppointerdef(def)^.definition^.deftype=orddef) and
+                   (porddef(ppointerdef(def)^.definition)^.typ=uchar) then
+                begin
+                   getlabel(ll);
+                   { insert string at the begin }
+                   if p^.treetype=stringconstn then
+                     generate_ascii_insert((p^.values^)+#0)
+                   else if is_constcharnode(p) then
+                     datasegment^.insert(new(pai_string,init(char(byte(p^.value))+#0)))
+                   else Message(cg_e_illegal_expression);
+                   datasegment^.insert(new(pai_label,init(ll)));
+                   { insert label }
+                   datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str(ll)))));
+                end
+              else if p^.treetype=addrn then
+                begin
+                   if (is_equal(ppointerdef(p^.resulttype)^.definition,ppointerdef(def)^.definition) or
+                      (is_equal(ppointerdef(p^.resulttype)^.definition,voiddef)) or
+                      (is_equal(ppointerdef(def)^.definition,voiddef))) and
+                      (p^.left^.treetype = loadn) then
+                     begin
+                        datasegment^.concat(new(pai_const,init_symbol(
+                          strpnew(p^.left^.symtableentry^.mangledname))));
+                        if p^.left^.symtableentry^.owner^.symtabletype=unitsymtable then
+                          concat_external(p^.left^.symtableentry^.mangledname,EXT_NEAR);
+                     end
+                   else
+                     Message(cg_e_illegal_expression);
+                end
+              else
+              { allow typeof(Object type)}
+                if (p^.treetype=inlinen) and
+                   (p^.inlinenumber=in_typeof_x) then
+                  if (p^.left^.treetype=typen) then
+                    begin
+                       datasegment^.concat(new(pai_const,init_symbol(
+                         strpnew(pobjectdef(p^.left^.resulttype)^.vmt_mangledname))));
+                       if pobjectdef(p^.left^.resulttype)^.owner^.symtabletype=unitsymtable then
+                          concat_external(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,EXT_NEAR);
+                    end
+                  else
+                    begin
+                       Message(cg_e_illegal_expression);
+                    end
+                else
+                  Message(cg_e_illegal_expression);
+              disposetree(p);
+           end;
+         setdef:
+           begin
+              p:=expr;
+              do_firstpass(p);
+              if p^.treetype=setconstrn then
+                begin
+                   { we only allow const sets }
+                   if assigned(p^.left) then
+                     Message(cg_e_illegal_expression)
+                   else
+                     begin
+                        for l:=0 to def^.savesize-1 do
+                          datasegment^.concat(
+                        new(pai_const,init_8bit(p^.constset^[l])));
+                     end;
+                end
+              else
+                Message(cg_e_illegal_expression);
+              disposetree(p);
+           end;
+         enumdef:
+       begin
+              p:=expr;
+              do_firstpass(p);
+              if p^.treetype=ordconstn then
+                begin
+                   if is_equal(p^.resulttype,def) then
+                     begin
+                        datasegment^.concat(new(pai_const,init_32bit(p^.value)));
+                     end
+                   else
+                     Message(cg_e_illegal_expression);
+                end
+              else
+                Message(cg_e_illegal_expression);
+              disposetree(p);
+           end;
+         stringdef:
+           begin
+              p:=expr;
+              do_firstpass(p);
+              if pstringdef(def)^.string_typ=shortstring then
+                begin
+                   if p^.treetype=stringconstn then
+                     begin
+                        s:=p^.values^;
+                        if length(s)+1>def^.size then
+                          s[0]:=char(def^.size-1);
+                        generate_ascii(char(length(s))+s);
+                     end
+                   else if is_constcharnode(p) then
+                     begin
+                        datasegment^.concat(new(pai_string,init(#1+char(byte(p^.value)))));
+                        s:=char(byte(p^.value));
+                     end
+                   else Message(cg_e_illegal_expression);
+                   if def^.size>length(s) then
+                     begin
+                        getmem(ca,def^.size-length(s));
+                        fillchar(ca[0],def^.size-length(s)-1,' ');
+                        ca[def^.size-length(s)-1]:=#0;
+                        datasegment^.concat(new(pai_string,init_pchar(ca)));
+                        disposetree(p);
+                     end;
+                end
+              else if pstringdef(def)^.string_typ=longstring then
+                begin
+                   if p^.treetype=stringconstn then
+                     begin
+                        s:=p^.values^;
+                        if length(s)+1>def^.size then
+                          s[0]:=char(def^.size-1);
+                        generate_ascii(char(length(s))+s);
+                     end
+                   else if is_constcharnode(p) then
+                     begin
+                        datasegment^.concat(new(pai_string,init(#1+char(byte(p^.value)))));
+                        s:=char(byte(p^.value));
+                     end
+                   else Message(cg_e_illegal_expression);
+                   if def^.size>length(s) then
+                     begin
+                        getmem(ca,def^.size-length(s));
+                        fillchar(ca[0],def^.size-length(s)-1,' ');
+                        ca[def^.size-length(s)-1]:=#0;
+                        datasegment^.concat(new(pai_string,init_pchar(ca)));
+                        disposetree(p);
+                     end;
+                end
+              else if pstringdef(def)^.string_typ=ansistring then
+                begin
+                end
+           end;
+         arraydef:
+           begin
+              if token=LKLAMMER then
+                begin
+                    consume(LKLAMMER);
+                    for l:=parraydef(def)^.lowrange to parraydef(def)^.highrange-1 do
+                      begin
+                         readtypedconst(parraydef(def)^.definition);
+                         consume(COMMA);
+                      end;
+                    readtypedconst(parraydef(def)^.definition);
+                    consume(RKLAMMER);
+                 end
+              else
+                begin
+                   p:=expr;
+                   do_firstpass(p);
+                   if p^.treetype=stringconstn then
+                     s:=p^.values^
+                   else if is_constcharnode(p) then
+                     s:=char(byte(p^.value))
+                   else Message(cg_e_illegal_expression);
+                   l:=length(s);
+                   for i:=Parraydef(def)^.lowrange to Parraydef(def)^.highrange do
+                     begin
+                        if i+1-Parraydef(def)^.lowrange<=l then
+                          begin
+                             datasegment^.concat(new(pai_const,init_8bit(byte(s[1]))));
+                             delete(s,1,1);
+                          end
+                        else
+                          {Fill the remaining positions with #0.}
+                          datasegment^.concat(new(pai_const,init_8bit(0)));
+                     end;
+                   if length(s)>0 then
+                     Message(parser_e_string_too_long);
+                 end;
+           end;
+         procvardef:
+           begin
+              { Procvars and pointers are no longer compatible.  }
+              { under tp:  =nil or =var under fpc: =nil or =@var }
+              if token=_NIL then
+                begin
+                   datasegment^.concat(new(pai_const,init_32bit(0)));
+                   consume(_NIL);
+                   exit;
+                end
+              else
+              if not(cs_tp_compatible in aktswitches) then
+                if token=KLAMMERAFFE then
+                  consume(KLAMMERAFFE);
+              getsym(pattern,true);
+              consume(ID);
+              if srsym^.typ=unitsym then
+                      begin
+                         consume(POINT);
+                         getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
+                         consume(ID);
+                      end;
+                    if srsym^.typ<>procsym then
+                      Message(cg_e_illegal_expression)
+                    else
+                      begin
+                         pd:=pprocsym(srsym)^.definition;
+                         if assigned(pd^.nextoverloaded) then
+                           Message(parser_e_no_overloaded_procvars);
+                         if not((pprocvardef(def)^.options=pd^.options)) or
+                           not(is_equal(pprocvardef(def)^.retdef,pd^.retdef)) then
+                           Message(sym_e_type_mismatch)
+                           else
+                              begin
+                                 hp1:=pprocvardef(def)^.para1;
+                                 hp2:=pd^.para1;
+                                 while assigned(hp1) and assigned(hp2) do
+                                   begin
+                                      if not(is_equal(hp1^.data,hp2^.data)) or
+                                         not(hp1^.paratyp=hp2^.paratyp) then
+                                        begin
+                                           Message(sym_e_type_mismatch);
+                                           break;
+                                        end;
+                                      hp1:=hp1^.next;
+                                      hp2:=hp2^.next;
+                                   end;
+                                 if not((hp1=nil) and (hp2=nil)) then
+                                   Message(sym_e_type_mismatch);
+                              end;
+                         datasegment^.concat(new(pai_const,init_symbol(strpnew(pd^.mangledname))));
+                         if pd^.owner^.symtabletype=unitsymtable then
+                           concat_external(pd^.mangledname,EXT_NEAR);
+                      end;
+           end;
+         { reads a typed constant record }
+         recorddef:
+           begin
+              consume(LKLAMMER);
+              aktpos:=0;
+              while token<>RKLAMMER do
+                begin
+                   s:=pattern;
+                   consume(ID);
+                   consume(COLON);
+                   srsym:=precdef(def)^.symtable^.search(s);
+                   if srsym=nil then
+                     begin
+                        Message1(sym_e_id_not_found,s);
+                        consume_all_until(SEMICOLON);
+                     end
+                   else
+                     begin
+                        { check position }
+                        if pvarsym(srsym)^.address<aktpos then
+                          Message(parser_e_invalid_record_const);
+
+                        { if needed fill }
+                        if pvarsym(srsym)^.address>aktpos then
+                          for i:=1 to pvarsym(srsym)^.address-aktpos do
+                            datasegment^.concat(new(pai_const,init_8bit(0)));
+
+                        { new position }
+                        aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.definition^.size;
+
+                        { read the data }
+                        readtypedconst(pvarsym(srsym)^.definition);
+
+                        if token=SEMICOLON then
+                          consume(SEMICOLON)
+                        else break;
+                     end;
+                end;
+              for i:=1 to def^.size-aktpos do
+                datasegment^.concat(new(pai_const,init_8bit(0)));
+              consume(RKLAMMER);
+           end;
+         else Message(parser_e_type_const_not_possible);
+         end;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.13  1998/03/20 23:31:35  florian
+    * bug0113 fixed
+    * problem with interdepened units fixed ("options.pas problem")
+    * two small extensions for future AMD 3D support
+
+  Revision 1.12  1998/03/18 22:50:11  florian
+    + fstp/fld optimization
+    * routines which contains asm aren't longer optimzed
+    * wrong ifdef TEST_FUNCRET corrected
+    * wrong data generation for array[0..n] of char = '01234'; fixed
+    * bug0097 is fixed partial
+    * bug0116 fixed (-Og doesn't use enter of the stack frame is greater than
+      65535)
+
+  Revision 1.11  1998/03/13 22:45:59  florian
+    * small bug fixes applied
+
+  Revision 1.10  1998/03/11 11:23:57  florian
+    * bug0081 and bug0109 fixed
+
+  Revision 1.9  1998/03/10 01:17:25  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.8  1998/03/06 00:52:50  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.7  1998/03/02 01:49:10  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:33  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.5  1998/02/12 11:50:32  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.4  1998/01/24 23:08:19  carl
+    + compile time range checking should logically always be on!
+
+  Revision 1.3  1998/01/23 17:12:20  pierre
+    * added some improvements for as and ld :
+      - doserror and dosexitcode treated separately
+      - PATH searched if doserror=2
+    + start of long and ansi string (far from complete)
+      in conditionnal UseLongString and UseAnsiString
+    * options.pas cleaned (some variables shifted to globals)gl
+
+  Revision 1.2  1998/01/09 09:10:03  michael
+  + Initial implementation, second try
+
+}

compiler/ra68k.pas

@@ -0,0 +1,2201 @@
+{
+    $Id$
+    Copyright (c) 1997-98 by Carl Eric Codere
+
+    This unit does the parsing process for the motorola 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 Ra68k;
+{**********************************************************************}
+{ WARNING                                                              }
+{**********************************************************************}
+{  Any modification in the order or removal of terms in the tables     }
+{  in m68k.pas and asmo68k.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 Add support for sized indexing such as in d0.l                         }
+{      presently only (an,dn) is supported for indexing --                  }
+{        size defaults to LONG.                                             }
+{  o Add support for MC68020 opcodes.                                       }
+{  o Add support for MC68020 adressing modes.                               }
+{  o Add operand checking with m68k opcode table in ConcatOpCode            }
+{  o Add Floating point support                                             }
+{---------------------------------------------------------------------------}
+
+Interface
+
+Uses
+  m68k,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_D0;
+ lastreg        = R_FPSR;
+
+type
+ tiasmops = array[firstop..lastop] of string[7];
+ piasmops = ^tiasmops;
+
+ tasmkeyword = string[6];
+
+var
+ { sorted tables of opcodes }
+ iasmops: piasmops;
+ { uppercased tables of registers }
+ iasmregs: array[firstreg..lastreg] of string[6];
+
+
+Implementation
+
+uses
+  globals,AsmUtils,strings,hcodegen,scanner,aasm,
+  cobjects,verbose,symtable;
+
+
+type
+ tmotorolatoken = (
+   AS_NONE,AS_LABEL,AS_LLABEL,AS_STRING,AS_HEXNUM,AS_OCTALNUM,
+   AS_BINNUM,AS_COMMA,AS_LBRACKET,AS_RBRACKET,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_APPT,AS_REALNUM,
+   AS_ALIGN,
+     {------------------ Assembler directives --------------------}
+   AS_DB,AS_DW,AS_DD,AS_XDEF,AS_END,
+     {------------------ Assembler Operators  --------------------}
+   AS_MOD,AS_SHL,AS_SHR,AS_NOT,AS_AND,AS_OR,AS_XOR);
+
+const
+   firstdirective = AS_DB;
+   lastdirective  = AS_END;
+   firstoperator  = AS_MOD;
+   lastoperator   = AS_XOR;
+
+   _count_asmdirectives = longint(lastdirective)-longint(firstdirective);
+   _count_asmoperators  = longint(lastoperator)-longint(firstoperator);
+
+   _asmdirectives : array[0.._count_asmdirectives] of tasmkeyword =
+    ('DC.B','DC.W','DC.L','XDEF','END');
+
+    { problems with shl,shr,not,and,or and xor, they are }
+    { context sensitive.                                 }
+    _asmoperators : array[0.._count_asmoperators] of tasmkeyword = (
+    'MOD','SHL','SHR','NOT','AND','OR','XOR');
+
+
+const
+  newline = #10;
+  firsttoken : boolean = TRUE;
+  operandnum : byte = 0;
+var
+ p : paasmoutput;
+ actasmtoken: tmotorolatoken;
+ actasmpattern: string;
+ c: char;
+ Instr: TInstruction;
+ labellist: TAsmLabelList;
+ old_exit : pointer;
+
+   Procedure SetupTables;
+   { creates uppercased symbol tables for speed access }
+   var
+     i: tasmop;
+     j: tregister;
+   Begin
+     Message(assem_d_creating_lookup_tables);
+     { opcodes }
+     new(iasmops);
+     for i:=firstop to lastop do
+      iasmops^[i] := upper(mot_op2str[i]);
+     { opcodes }
+     for j:=firstreg to lastreg do
+      iasmregs[j] := upper(mot_reg2str[j]);
+   end;
+
+
+    procedure ra68k_exit;far;
+      begin
+         if assigned(iasmops) then
+           dispose(iasmops);
+         exitproc:=old_exit;
+      end;
+
+  {---------------------------------------------------------------------}
+  {                     Routines for the tokenizing                     }
+  {---------------------------------------------------------------------}
+
+
+   function is_asmopcode(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.                        }
+  {  Remark: Suffixes are also checked, as long as they are valid.      }
+  {*********************************************************************}
+   var
+    i: tasmop;
+    j: byte;
+   Begin
+     is_asmopcode := FALSE;
+     { first of all we remove the suffix }
+     j:=pos('.',s);
+     if j<>0 then
+      delete(s,j,2);
+     for i:=firstop to lastop do
+     begin
+       if  s = iasmops^[i] then
+       begin
+          is_asmopcode:=TRUE;
+          exit;
+       end;
+     end;
+   end;
+
+
+
+   Procedure is_asmdirective(const s: string; var token: tmotorolatoken);
+  {*********************************************************************}
+  { 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 := tmotorolatoken(longint(firstdirective)+i);
+           exit;
+        end;
+     end;
+   end;
+
+
+   Procedure is_register(const s: string; var token: tmotorolatoken);
+  {*********************************************************************}
+  { 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;
+     { take care of other name for sp }
+     if s = 'A7' then
+     begin
+      token:=AS_REGISTER;
+      exit;
+     end;
+   end;
+
+
+
+  Function GetToken: tmotorolatoken;
+  {*********************************************************************}
+  { FUNCTION GetToken: tinteltoken;                                     }
+  {  Description: This routine returns intel assembler tokens and       }
+  {  does some minor syntax error checking.                             }
+  {*********************************************************************}
+  var
+   j: integer;
+   token: tmotorolatoken;
+   forcelabel: boolean;
+   errorflag : boolean;
+  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;
+      if c = '@' then
+      begin
+        token := AS_LLABEL;   { this is a local label }
+        { Let us point to the next character }
+        c := asmgetchar;
+      end;
+
+
+
+      while c in ['A'..'Z','a'..'z','0'..'9','_','@','.'] do
+      begin
+         { if there is an at_sign, then this must absolutely be a label }
+         if c = '@' then forcelabel:=TRUE;
+         actasmpattern := actasmpattern + c;
+         c := asmgetchar;
+      end;
+
+      uppervar(actasmpattern);
+
+      if c = ':' then
+      begin
+           case token of
+             AS_NONE: token := AS_LABEL;
+             AS_LLABEL: ; { do nothing }
+           end; { end case }
+           { let us point to the next character }
+           c := asmgetchar;
+           gettoken := token;
+           exit;
+      end;
+
+      { Are we trying to create an identifier with }
+      { an at-sign...?                             }
+      if forcelabel then
+       Message(assem_e_none_label_contain_at);
+
+      If is_asmopcode(actasmpattern) then
+      Begin
+       gettoken := AS_OPCODE;
+       exit;
+      end;
+      is_asmdirective(actasmpattern, token);
+      if (token <> AS_NONE) then
+      Begin
+        gettoken := token;
+        exit
+      end
+      else
+      begin
+         gettoken := AS_NONE;
+         Message1(assem_e_invalid_operand,actasmpattern);
+      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 }
+                {                - @Result, @Code or @Data special variables.     }
+                            begin
+                             actasmpattern := c;
+                             c:= asmgetchar;
+                             while c in  ['A'..'Z','a'..'z','0'..'9','_','@','.'] do
+                             begin
+                               actasmpattern := actasmpattern + c;
+                               c := asmgetchar;
+                             end;
+                             uppervar(actasmpattern);
+                             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;
+                             uppervar(actasmpattern);
+
+                             If is_asmopcode(actasmpattern) then
+                             Begin
+                                    gettoken := AS_OPCODE;
+                                    exit;
+                             end;
+                             is_register(actasmpattern, token);
+                             {is_asmoperator(actasmpattern,token);}
+                             is_asmdirective(actasmpattern,token);
+                             { 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;
+           { override operator... not supported }
+           '&':       begin
+                         c:=asmgetchar;
+                         gettoken := AS_AND;
+                      end;
+           { string or character }
+           '''' :
+                      begin
+                         actasmpattern:='';
+                         while true do
+                         begin
+                           if c = '''' then
+                           begin
+                              c:=asmgetchar;
+                              if c=newline then
+                              begin
+                                 Message(scan_f_string_exceeds_line);
+                                 break;
+                              end;
+                              repeat
+                                  if c=''''then
+                                   begin
+                                       c:=asmgetchar;
+                                       if c='''' then
+                                        begin
+                                               actasmpattern:=actasmpattern+'''';
+                                               c:=asmgetchar;
+                                               if c=newline then
+                                               begin
+                                                    Message(scan_f_string_exceeds_line);
+                                                    break;
+                                               end;
+                                        end
+                                        else break;
+                                   end
+                                   else
+                                   begin
+                                          actasmpattern:=actasmpattern+c;
+                                          c:=asmgetchar;
+                                          if c=newline then
+                                            begin
+                                               Message(scan_f_string_exceeds_line);
+                                               break
+                                            end;
+                                   end;
+                              until false; { end repeat }
+                           end
+                           else break; { end if }
+                         end; { end while }
+                   token:=AS_STRING;
+                   gettoken := token;
+                   exit;
+                 end;
+           '$' :  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;
+           ',' : begin
+                   gettoken := AS_COMMA;
+                   c:=asmgetchar;
+                   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_DOT;
+                   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
+                   gettoken := AS_SLASH;
+                   c:=asmgetchar;
+                   exit;
+                 end;
+           '<' : begin
+                   c := asmgetchar;
+                   { invalid characters }
+                   if c <> '<' then
+                    Message(assem_e_invalid_char_smaller);
+                   { still assume << }
+                   gettoken := AS_SHL;
+                   c := asmgetchar;
+                   exit;
+                 end;
+           '>' : begin
+                   c := asmgetchar;
+                   { invalid characters }
+                   if c <> '>' then
+                    Message(assem_e_invalid_char_greater);
+                   { still assume << }
+                   gettoken := AS_SHR;
+                   c := asmgetchar;
+                   exit;
+                 end;
+           '|' : begin
+                   gettoken := AS_OR;
+                   c := asmgetchar;
+                   exit;
+                 end;
+           '^' : begin
+                  gettoken := AS_XOR;
+                  c := asmgetchar;
+                  exit;
+                 end;
+           '#' : begin
+                  gettoken:=AS_APPT;
+                  c:=asmgetchar;
+                  exit;
+                 end;
+           '%' : begin
+                   c:=asmgetchar;
+                   while c in ['0','1'] do
+                   Begin
+                     actasmpattern := actasmpattern + c;
+                     c := asmgetchar;
+                   end;
+                   gettoken := AS_BINNUM;
+                   exit;
+                 end;
+           { integer number }
+           '0'..'9': begin
+                        actasmpattern := c;
+                        c := asmgetchar;
+                        while c in ['0'..'9'] do
+                          Begin
+                             actasmpattern := actasmpattern + c;
+                             c:= asmgetchar;
+                          end;
+                        gettoken := AS_INTNUM;
+                        exit;
+                     end;
+         ';' : begin
+                  repeat
+                     c:=asmgetchar;
+                  until c=newline;
+                  firsttoken := TRUE;
+                  gettoken:=AS_SEPARATOR;
+               end;
+
+         '{',#13,newline : begin
+                            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 parsing                        }
+  {---------------------------------------------------------------------}
+
+     procedure consume(t : tmotorolatoken);
+
+     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;
+    if s = 'A7' then
+    Begin
+      findregister := R_SP;
+      exit;
+    end;
+   end;
+
+
+   function findopcode(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;
+    op_size: string;
+   Begin
+     findopcode := A_NONE;
+     j:=pos('.',s);
+     if j<>0 then
+     begin
+       op_size:=copy(s,j+1,1);
+       case op_size[1] of
+       { For the motorola only stropsize size is used to }
+       { determine the size of the operands.             }
+       'B': instr.stropsize := S_B;
+       'W': instr.stropsize := S_W;
+       'L': instr.stropsize := S_L;
+       'S': instr.stropsize := S_S;
+       'D': instr.stropsize := S_Q;
+       'X': instr.stropsize := S_X;
+       else
+        Message1(assem_e_invalid_opcode,s);
+       end;
+       { delete everything starting from dot }
+       delete(s,j,length(s));
+     end;
+     for i:=firstop to lastop do
+       if  s = iasmops^[i] then
+       begin
+          findopcode:=i;
+          exit;
+       end;
+   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].ref.direction := dir_none;
+        operands[operandnum].operandtype := OPR_REFERENCE;
+        operands[operandnum].ref.segment := R_DEFAULT_SEG;
+     end;
+   end;
+
+
+
+
+  Function CalculateExpression(expression: string): longint;
+  var
+    expr: TExprParse;
+  Begin
+   expr.Init;
+   CalculateExpression := expr.Evaluate(expression);
+   expr.Done;
+  end;
+
+
+  Procedure ConcatOpCode(var instr: TInstruction);
+  var
+    fits : boolean;
+    i: longint;
+    opsize: topsize;
+    optyp1, optyp2, optyp3: longint;
+    instruc: tasmop;
+    op: tasmop;
+  Begin
+     fits := FALSE;
+    { setup specific instructions for first pass }
+    instruc := instr.getinstruction;
+
+    { Setup special operands }
+    { Convert to general form as to conform to the m68k opcode table }
+    if (instruc = A_ADDA) or (instruc = A_ADDI)
+       then instruc := A_ADD
+    else
+    { CMPM excluded because of GAS v1.34 BUG }
+    if (instruc = A_CMPA) or
+       (instruc = A_CMPI) then
+       instruc := A_CMP
+    else
+    if instruc = A_EORI then
+      instruc := A_EOR
+    else
+    if instruc = A_MOVEA then
+     instruc := A_MOVE
+    else
+    if instruc = A_ORI then
+      instruc := A_OR
+    else
+    if (instruc = A_SUBA) or (instruc = A_SUBI) then
+      instruc :=  A_SUB;
+
+    { Setup operand types }
+
+(*
+    in instruc <> A_MOVEM then
+    Begin
+
+      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;
+                end;
+            2 : if ((optyp1 and it[i].o1)<>0) and
+                 ((optyp2 and it[i].o2)<>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_combination_opcode_and_operand);
+          exit;
+        end;
+        inc(i);
+       end; { end while }
+             *)
+  fits:=TRUE;
+
+  { We add the opcode to the opcode linked list }
+  if fits then
+  Begin
+    case instr.numops of
+     0:
+        if instr.stropsize <> S_NO then
+          p^.concat(new(pai68k,op_none(instruc,instr.stropsize)))
+        else
+          p^.concat(new(pai68k,op_none(instruc,S_NO)));
+     1: Begin
+          case instr.operands[1].operandtype of
+           OPR_CONSTANT: Begin
+                             p^.concat(new(pai68k,op_const(instruc,
+                               instr.stropsize, instr.operands[1].val)));
+                         end;
+           OPR_REGISTER:  p^.concat(new(pai68k,op_reg(instruc,
+                            instr.stropsize,instr.operands[1].reg)));
+           OPR_REFERENCE:
+                          if instr.stropsize <> S_NO then
+                          Begin
+                           p^.concat(new(pai68k,op_ref(instruc,
+                            instr.stropsize,newreference(instr.operands[1].ref))));
+                          end
+                          else
+                          Begin
+                              { special jmp and call case with }
+                              { symbolic references.           }
+                              if instruc in [A_BSR,A_JMP,A_JSR,A_BRA,A_PEA] then
+                              Begin
+                                p^.concat(new(pai68k,op_ref(instruc,
+                                  S_NO,newreference(instr.operands[1].ref))));
+                              end
+                              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
+                With instr do
+                Begin
+                { source }
+                  case operands[1].operandtype of
+                  { reg,reg     }
+                  { reg,ref     }
+                   OPR_REGISTER:
+                     Begin
+                       case operands[2].operandtype of
+                         OPR_REGISTER:
+                            Begin
+                               p^.concat(new(pai68k,op_reg_reg(instruc,
+                               stropsize,operands[1].reg,operands[2].reg)));
+                            end;
+                         OPR_REFERENCE:
+                                  p^.concat(new(pai68k,op_reg_ref(instruc,
+                                  stropsize,operands[1].reg,newreference(operands[2].ref))));
+                       else { else case }
+                         Begin
+                           Message(assem_f_internal_error_in_concatopcode);
+                         end;
+                       end; { end inner case }
+                     end;
+                  { reglist, ref }
+                   OPR_REGLIST:
+                          Begin
+                            case operands[2].operandtype of
+                              OPR_REFERENCE :
+                                  p^.concat(new(pai68k,op_reglist_ref(instruc,
+                                  stropsize,operands[1].list,newreference(operands[2].ref))));
+                            else
+                             Begin
+                               Message(assem_f_internal_error_in_concatopcode);
+                             end;
+                            end; { end 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(pai68k,op_const_const(instruc,
+                           S_NO,operands[1].val,operands[2].val)));
+                        OPR_REFERENCE:
+                           Begin
+                                 p^.concat(new(pai68k,op_const_ref(instruc,
+                                 stropsize,operands[1].val,
+                                 newreference(operands[2].ref))))
+                           end;
+                        OPR_REGISTER:
+                           Begin
+                                 p^.concat(new(pai68k,op_const_reg(instruc,
+                                 stropsize,operands[1].val,
+                                 operands[2].reg)))
+                           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:
+                            Begin
+                              p^.concat(new(pai68k,op_ref_reg(instruc,
+                               stropsize,newreference(operands[1].ref),
+                               operands[2].reg)));
+                            end;
+                         OPR_REGLIST:
+                            Begin
+                              p^.concat(new(pai68k,op_ref_reglist(instruc,
+                               stropsize,newreference(operands[1].ref),
+                               operands[2].list)));
+                            end;
+                         OPR_REFERENCE: { special opcodes }
+                            p^.concat(new(pai68k,op_ref_ref(instruc,
+                            stropsize,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;
+     3: Begin
+           if (instruc = A_DIVSL) or (instruc = A_DIVUL) or (instruc = A_MULU)
+           or (instruc = A_MULS) or (instruc = A_DIVS) or (instruc = A_DIVU) then
+           Begin
+             if (instr.operands[1].operandtype <> OPR_REGISTER)
+             or (instr.operands[2].operandtype <> OPR_REGISTER)
+             or (instr.operands[3].operandtype <> OPR_REGISTER) then
+             Begin
+               Message(assem_f_internal_error_in_concatopcode);
+             end
+             else
+             Begin
+               p^.concat(new(pai68k, op_reg_reg_reg(instruc,instr.stropsize,
+                 instr.operands[1].reg,instr.operands[2].reg,instr.operands[3].reg)));
+             end;
+           end
+           else
+            Message(assem_e_unsupported_opcode);
+        end;
+  end; { end case }
+ end;
+ end;
+
+
+    Procedure ConcatLabeledInstr(var instr: TInstruction);
+    Begin
+       if ((instr.getinstruction >= A_BCC) and (instr.getinstruction <= A_BVS))
+       or (instr.getinstruction = A_BRA) or (instr.getinstruction = A_BSR)
+       or (instr.getinstruction = A_JMP) or (instr.getinstruction = A_JSR)
+       or ((instr.getinstruction >= A_FBEQ) and (instr.getinstruction <= A_FBNGLE))
+       then
+       Begin
+        if instr.numops > 2 then
+          Message(assem_e_invalid_opcode)
+        else if instr.operands[1].operandtype <> OPR_LABINSTR then
+          Message(assem_e_invalid_opcode)
+        else if (instr.operands[1].operandtype = OPR_LABINSTR) and
+         (instr.numops = 1) then
+           if assigned(instr.operands[1].hl) then
+            ConcatLabel(p,instr.getinstruction, instr.operands[1].hl)
+           else
+            Message(assem_f_internal_error_in_findtype);
+       end
+       else
+       if ((instr.getinstruction >= A_DBCC) and (instr.getinstruction <= A_DBF))
+       or ((instr.getinstruction >= A_FDBEQ) and (instr.getinstruction <= A_FBDNGLE)) then
+       begin
+         p^.concat(new(pai_labeled,init_reg(instr.getinstruction,instr.operands[2].hl,
+           instr.operands[1].reg)));
+       end
+       else
+        Message(assem_e_invalid_operand);
+    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_STAR  token.           }
+  {*********************************************************************}
+  var str:string;
+      l: longint;
+      code: integer;
+  Begin
+     Consume(AS_STAR);
+     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);
+     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)       // }
+                         { // (reg)+      // }
+                         if actasmtoken=AS_RPAREN then
+                         Begin
+                           Consume(AS_RPAREN);
+                           if actasmtoken = AS_PLUS then
+                           Begin
+                             if (instr.operands[operandnum].ref.direction <> dir_none) then
+                              Message(assem_e_no_inc_and_dec_together)
+                             else
+                               instr.operands[operandnum].ref.direction := dir_inc;
+                             Consume(AS_PLUS);
+                           end;
+                           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 .. // }
+                       Consume(AS_COMMA);
+                       if actasmtoken = AS_REGISTER then
+                       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_STAR:
+                              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;
+       AS_HEXNUM,AS_OCTALNUM,   { direct address }
+       AS_BINNUM,AS_INTNUM: 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;
+                                Consume(actasmtoken);
+                                val(str, l, code);
+                                if code <> 0 then
+                                     Message(assem_e_invalid_reference_syntax)
+                                else
+                                     instr.operands[operandnum].ref.offset := l;
+                                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;
+     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;
+    l : longint;
+    i: tregister;
+    hl: plabel;
+    reg_one, reg_two: tregister;
+    reglist: set of tregister;
+  Begin
+   reglist := [];
+   tempstr := '';
+   expr := '';
+   case actasmtoken of
+   { // Memory reference //  }
+     AS_LPAREN:
+               Begin
+                  initAsmRef(instr);
+                  BuildReference(instr);
+               end;
+   { // Constant expression //  }
+     AS_APPT:  Begin
+                      Consume(AS_APPT);
+                      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_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
+              if actasmpattern[1] = '@' then
+              { // Label or Special symbol reference // }
+              Begin
+                 if actasmpattern = '@RESULT' then
+                   Begin
+                      InitAsmRef(instr);
+                      SetUpResult(instr,operandnum);
+                   end
+                 else
+                  if (actasmpattern = '@CODE') or (actasmpattern = '@DATA') then
+                    Message(assem_w_CODE_and_DATA_not_supported)
+                   else
+                  Begin
+                    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
+                 Message(assem_e_syntax_error);
+              end
+              { probably a variable or normal expression }
+              { or a procedure (such as in CALL ID)      }
+              else
+               Begin
+                   { is it a constant ? }
+                   if SearchIConstant(actasmpattern,l) then
+                   Begin
+                      InitAsmRef(instr);
+                      instr.operands[operandnum].ref.offset:=BuildRefExpression;
+                      BuildReference(instr);
+
+{                      if not (instr.operands[operandnum].operandtype in [OPR_NONE,OPR_CONSTANT]) then
+                        Message(assem_e_invalid_operand_type);
+                      instr.operands[operandnum].operandtype := OPR_CONSTANT;
+                      instr.operands[operandnum].val :=BuildExpression;}
+                    end
+                   else { is it a label variable ? }
+                    Begin
+                     { // ID[ , ID.Field.Field or simple ID // }
+                     { 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
+                         { not a variable.. }
+                         { check special variables.. }
+                         if actasmpattern = 'SELF' then
+                          { special self variable }
+                         Begin
+                           if assigned(procinfo._class) then
+                             Begin
+                               instr.operands[operandnum].ref.offset := procinfo.ESI_offset;
+                               instr.operands[operandnum].ref.base := procinfo.framepointer;
+                             end
+                           else
+                             Message(assem_e_cannot_use_SELF_outside_a_method);
+                         end
+                         else
+                         if (cs_compilesystem in aktswitches) then
+                         Begin
+                           if not assigned(instr.operands[operandnum].ref.symbol) then
+                           Begin
+                             instr.operands[operandnum].ref.symbol:=newpasstr(actasmpattern);
+                             Message1(assem_w_id_supposed_external,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;
+                    end;
+               end;
+            end;
+   { // Pre-decrement mode reference or constant mem offset.   // }
+     AS_MINUS:    Begin
+                   Consume(AS_MINUS);
+                   if actasmtoken = AS_LPAREN then
+                   Begin
+                     InitAsmRef(instr);
+                     { indicate pre-decrement mode }
+                     instr.operands[operandnum].ref.direction := dir_dec;
+                     BuildReference(instr);
+                   end
+                   else
+                   if actasmtoken in [AS_OCTALNUM,AS_HEXNUM,AS_BINNUM,AS_INTNUM] then
+                   Begin
+                      InitAsmRef(instr);
+                      instr.operands[operandnum].ref.offset:=BuildRefExpression;
+                      BuildReference(instr);
+                   end
+                   else
+                   Begin
+                    Message(assem_e_syntax_error);
+                    while not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do
+                       Consume(actasmtoken);
+                   end;
+                  end;
+   { // Register, a variable reference or a constant reference // }
+     AS_REGISTER: Begin
+                   { save the type of register used. }
+                   tempstr := actasmpattern;
+                   Consume(AS_REGISTER);
+                   { // Simple register // }
+                   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
+                   { HERE WE MUST HANDLE THE SPECIAL CASE OF MOVEM AND FMOVEM }
+                   { // Individual register listing // }
+                   if (actasmtoken = AS_SLASH) then
+                   Begin
+                     reglist := [findregister(tempstr)];
+                     Consume(AS_SLASH);
+                     if actasmtoken = AS_REGISTER then
+                     Begin
+                       While not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do
+                       Begin
+                         case actasmtoken of
+                          AS_REGISTER: Begin
+                                        reglist := reglist + [findregister(actasmpattern)];
+                                        Consume(AS_REGISTER);
+                                       end;
+                          AS_SLASH: Consume(AS_SLASH);
+                          AS_SEPARATOR,AS_COMMA: break;
+                         else
+                          Begin
+                            Message(assem_e_invalid_reg_list_in_movem);
+                            Consume(actasmtoken);
+                          end;
+                         end; { end case }
+                       end; { end while }
+                       instr.operands[operandnum].operandtype:= OPR_REGLIST;
+                       instr.operands[operandnum].list := reglist;
+                     end
+                     else
+                      { error recovery ... }
+                      Begin
+                            Message(assem_e_invalid_reg_list_in_movem);
+                            while not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do
+                               Consume(actasmtoken);
+                      end;
+                   end
+                   else
+                   { // Range register listing // }
+                   if (actasmtoken = AS_MINUS) then
+                   Begin
+                     Consume(AS_MINUS);
+                     reg_one:=findregister(tempstr);
+                     if actasmtoken <> AS_REGISTER then
+                     Begin
+                       Message(assem_e_invalid_reg_list_in_movem);
+                       while not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do
+                         Consume(actasmtoken);
+                     end
+                     else
+                     Begin
+                      { determine the register range ... }
+                      reg_two:=findregister(actasmpattern);
+                      if reg_one > reg_two then
+                      begin
+                       for i:=reg_two to reg_one do
+                         reglist := reglist + [i];
+                      end
+                      else
+                      Begin
+                       for i:=reg_one to reg_two do
+                         reglist := reglist + [i];
+                      end;
+                      Consume(AS_REGISTER);
+                      if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then
+                      Begin
+                       Message(assem_e_invalid_reg_list_in_movem);
+                       while not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do
+                         Consume(actasmtoken);
+                      end;
+                      { set up instruction }
+                      instr.operands[operandnum].operandtype:= OPR_REGLIST;
+                      instr.operands[operandnum].list := reglist;
+                     end;
+                   end
+                   else
+                   { DIVSL/DIVS/MULS/MULU with long for MC68020 only }
+                   if (actasmtoken = AS_COLON) then
+                   Begin
+                     if (opt_processors = MC68020) or (cs_compilesystem in aktswitches) then
+                     Begin
+                       Consume(AS_COLON);
+                       if (actasmtoken = AS_REGISTER) then
+                       Begin
+                         { set up old field, since register is valid }
+                         instr.operands[operandnum].operandtype := OPR_REGISTER;
+                         instr.operands[operandnum].reg := findregister(tempstr);
+                         Inc(operandnum);
+                         instr.operands[operandnum].operandtype := OPR_REGISTER;
+                         instr.operands[operandnum].reg := findregister(actasmpattern);
+                         Consume(AS_REGISTER);
+                         if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then
+                         Begin
+                          Message(assem_e_invalid_reg_list_for_opcode);
+                          while not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do
+                            Consume(actasmtoken);
+                         end;
+                       end;
+                     end
+                     else
+                     Begin
+                        Message(assem_e_68020_mode_required);
+                        if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then
+                        Begin
+                          Message(assem_e_invalid_reg_list_for_opcode);
+                          while not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do
+                            Consume(actasmtoken);
+                        end;
+                     end;
+                   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;
+   tempstr: 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_constant_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 }
+
+    { //  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);
+      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_motorola);
+    firsttoken := TRUE;
+    operandnum := 0;
+    { 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,'@'+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
+                       Message1(assem_e_unknown_label_identifer,actasmpattern);
+                     end;
+                     Consume(AS_LABEL);
+                 end;
+        AS_DW:   Begin
+                   Consume(AS_DW);
+                   BuildConstant($ffff);
+                 end;
+        AS_DB:   Begin
+                  Consume(AS_DB);
+                  BuildConstant($ff);
+                end;
+        AS_DD:   Begin
+                 Consume(AS_DD);
+                 BuildConstant($ffffffff);
+                end;
+        AS_XDEF:
+                  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_XDEF);
+                      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_xdef_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_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,'@'+labelptr^.name^);
+         labelptr:=nextlabel;
+      end;
+  end;
+  assemble := genasmnode(p);
+  labellist.done;
+  Message(assem_d_finish_motorola);
+end;
+
+Begin
+   old_exit:=exitproc;
+   exitproc:=@ra68k_exit;
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.14  1998/03/22 12:45:38  florian
+    * changes of Carl-Eric to m68k target commit:
+      - wrong nodes because of the new string cg in intel, I had to create
+        this under m68k also ... had to work it out to fix potential alignment
+        problems --> this removes the crash of the m68k compiler.
+      - added absolute addressing in m68k assembler (required for Amiga startup)
+      - fixed alignment problems (because of byte return values, alignment
+        would not be always valid) -- is this ok if i change the offset if odd in
+        setfirsttemp ?? -- it seems ok...
+
+  Revision 1.13  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.12  1998/03/10 01:17:25  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+}
+
+

compiler/radi386.pas

@@ -0,0 +1,300 @@
+{
+    $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))));
+            { if function return is param }
+            { consider it set if the offset was loaded }
+           if assigned(procinfo.retdef) and
+              ret_in_param(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
+          (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
+                                   (s[length(s)]<>'$') 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;
+                                                  if pos(',',s) > 0 then
+                                                    procinfo.funcret_is_valid:=true;
+                                                  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
+                     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.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  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
+}

compiler/rai386.pas

@@ -0,0 +1,3465 @@
+{
+    $Id$
+    Copyright (c) 1997-98 by Carl Eric Codere
+
+    Does the parsing process for the intel 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 Rai386;
+
+{**********************************************************************}
+{ 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 Add support for floating point opcodes.                          }
+{ o Handle module overrides also... such as crt.white or             }
+{    crt.delay and local typed constants.                            }
+{ o Handle label references                                          }
+{ o Add support for TP styled segment overrides, when the opcode     }
+{    table will be completed.                                        }
+{ o Add imul,shld and shrd support with references and CL            }
+{    i386.pas requires to be updated to do this.                     }
+{ o Support for (* *) tp styled comments, this support should be     }
+{   added in asmgetchar in scanner.pas (it cannot be implemented     }
+{   here without causing errors such as in :                         }
+{   (* "openbrace" AComment *)                                       }
+{   (presently an infinite loop will be created if a (* styled       }
+{    comment is found).                                              }
+{ 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).                                                  }
+{--------------------------------------------------------------------}
+
+Interface
+
+uses
+  tree,i386;
+
+   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;
+
+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;
+
+
+type
+ tinteltoken = (
+   AS_NONE,AS_LABEL,AS_LLABEL,AS_STRING,AS_HEXNUM,AS_OCTALNUM,
+   AS_BINNUM,AS_COMMA,AS_LBRACKET,AS_RBRACKET,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,
+     {------------------ Assembler directives --------------------}
+   AS_DB,AS_DW,AS_DD,AS_END,
+     {------------------ Assembler Operators  --------------------}
+   AS_BYTE,AS_WORD,AS_DWORD,AS_QWORD,AS_TBYTE,AS_NEAR,AS_FAR,
+   AS_HIGH,AS_LOW,AS_OFFSET,AS_SEG,AS_TYPE,AS_PTR,AS_MOD,AS_SHL,AS_SHR,AS_NOT,
+   AS_AND,AS_OR,AS_XOR);
+
+   tasmkeyword = string[6];
+const
+   { These tokens should be modified accordingly to the modifications }
+   { in the different enumerations.                                   }
+   firstdirective = AS_DB;
+   lastdirective  = AS_END;
+   firstoperator  = AS_BYTE;
+   lastoperator   = AS_XOR;
+   firstsreg      = R_CS;
+   lastsreg       = R_SS;
+   { this is a hack to accept all opcodes }
+   { in the opcode table.                 }
+   { check is done until A_POPFD          }
+   { otherwise no check.                  }
+   lastop_in_table = A_POPFD;
+
+       _count_asmdirectives = longint(lastdirective)-longint(firstdirective);
+       _count_asmoperators  = longint(lastoperator)-longint(firstoperator);
+       _count_asmprefixes   = 5;
+       _count_asmspecialops = 25;
+       _count_asmoverrides  = 3;
+
+       _asmdirectives : array[0.._count_asmdirectives] of tasmkeyword =
+       ('DB','DW','DD','END');
+
+       { problems with shl,shr,not,and,or and xor, they are }
+       { context sensitive.                                 }
+       _asmoperators : array[0.._count_asmoperators] of tasmkeyword = (
+        'BYTE','WORD','DWORD','QWORD','TBYTE','NEAR','FAR','HIGH',
+        'LOW','OFFSET','SEG','TYPE','PTR','MOD','SHL','SHR','NOT','AND',
+        'OR','XOR');
+
+     {------------------ Missing opcodes from std list  ----------------}
+       _asmprefixes: array[0.._count_asmprefixes] of tasmkeyword = (
+       'REPNE','REPE','REP','REPZ','REPNZ','LOCK');
+
+       _asmoverrides: array[0.._count_asmoverrides] of tasmkeyword =
+       ('SEGCS','SEGDS','SEGES','SEGSS');
+
+       _overridetokens: array[0.._count_asmoverrides] of tregister =
+       (R_CS,R_DS,R_ES,R_SS);
+
+       _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','CMPSD','INSB','INSW','INSD','OUTSB','OUTSW','OUTSD',
+       'SCASB','SCASW','SCASD','STOSB','STOSW','STOSD','MOVSB','MOVSW','MOVSD',
+       'LODSB','LODSW','LODSD','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);
+
+
+
+
+const
+  newline = #10;
+  firsttoken : boolean = TRUE;
+  operandnum : byte = 0;
+var
+ { context for SHL,SHR,AND,NOT,OR,XOR operators }
+ { if set to true GetToken will return these    }
+ { as operators, otherwise will return these as }
+ { opcodes.                                     }
+ inexpression: boolean;
+ p : paasmoutput;
+ actasmtoken: tinteltoken;
+ actasmpattern: string;
+ c: char;
+ Instr: TInstruction;
+ labellist: TAsmLabelList;
+ old_exit : pointer;
+
+
+   Procedure SetupTables;
+   { creates uppercased symbol tables for speed access }
+   var
+     i: tasmop;
+     j: tregister;
+   Begin
+     Message(assem_d_creating_lookup_tables);
+     { opcodes }
+     new(iasmops);
+     for i:=firstop to lastop do
+      iasmops^[i] := upper(int_op2str[i]);
+     { opcodes }
+     for j:=firstreg to lastreg do
+      iasmregs[j] := upper(int_reg2str[j]);
+   end;
+
+
+    procedure rai386_exit;{$ifndef FPC}far;{$endif}
+
+      begin
+         if assigned(iasmops) then
+           dispose(iasmops);
+         exitproc:=old_exit;
+      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;
+   Begin
+     is_asmopcode := FALSE;
+     for i:=firstop to lastop do
+     begin
+       if  s = iasmops^[i] then
+       begin
+          is_asmopcode:=TRUE;
+          exit;
+       end;
+     end;
+     { not found yet, search for extended opcodes }
+     for j:=0 to _count_asmspecialops do
+     Begin
+       if s = _specialops[j] 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_asmoperator(const s: string; var token: tinteltoken);
+  {*********************************************************************}
+  { FUNCTION  is_asmoperator(s: string; var token: tinteltoken): Boolean}
+  {  Description: Determines if the s string is a valid operator        }
+  { (an operator can occur in operand fields, while a directive cannot) }
+  {  if so returns the operator token, otherwise does not change token. }
+  {*********************************************************************}
+   var
+    i:longint;
+   Begin
+     for i:=0 to _count_asmoperators do
+     begin
+        if s=_asmoperators[i] then
+        begin
+           token := tinteltoken(longint(firstoperator)+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
+   j: integer;
+   token: tinteltoken;
+   forcelabel: boolean;
+   errorflag : boolean;
+  begin
+    errorflag := FALSE;
+    forcelabel := FALSE;
+    actasmpattern :='';
+    {* INIT TOKEN TO NOTHING *}
+    token := AS_NONE;
+    { while space and tab , continue scan... }
+    while (c in [' ',#9]) do
+      c := asmgetchar;
+    { 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;
+      if c = '@' then
+      begin
+        token := AS_LLABEL;   { this is a local label }
+        { Let us point to the next character }
+        c := asmgetchar;
+      end;
+
+
+
+      while c in ['A'..'Z','a'..'z','0'..'9','_','@'] do
+      begin
+         { if there is an at_sign, then this must absolutely be a label }
+         if c = '@' then forcelabel:=TRUE;
+         actasmpattern := actasmpattern + c;
+         c := asmgetchar;
+      end;
+
+      uppervar(actasmpattern);
+
+      if c = ':' then
+      begin
+           case token of
+             AS_NONE: token := AS_LABEL;
+             AS_LLABEL: ; { do nothing }
+           end; { end case }
+           { let us point to the next character }
+           c := asmgetchar;
+           gettoken := token;
+           exit;
+      end;
+
+      { Are we trying to create an identifier with }
+      { an at-sign...?                             }
+      if forcelabel then
+       Message(assem_e_none_label_contain_at);
+
+      If is_asmopcode(actasmpattern) then
+      Begin
+       gettoken := AS_OPCODE;
+       { check if we are in an expression  }
+       { then continue with asm directives }
+       if not inexpression then
+         exit;
+      end;
+      is_asmdirective(actasmpattern, token);
+      if (token <> AS_NONE) then
+      Begin
+        gettoken := token;
+        exit
+      end
+      else
+      begin
+         gettoken := AS_NONE;
+         Message1(assem_e_invalid_operand,actasmpattern);
+      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 }
+                {                - @Result, @Code or @Data special variables.     }
+                            begin
+                             actasmpattern := c;
+                             c:= asmgetchar;
+                             while c in  ['A'..'Z','a'..'z','0'..'9','_','@'] do
+                             begin
+                               actasmpattern := actasmpattern + c;
+                               c := asmgetchar;
+                             end;
+                             uppervar(actasmpattern);
+                             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;
+                             uppervar(actasmpattern);
+
+                             If is_asmopcode(actasmpattern) then
+                             Begin
+                                    gettoken := AS_OPCODE;
+                                    { if we are not in a constant }
+                                    { expression than this is an  }
+                                    { opcode.                     }
+                                    if  not inexpression then
+                                    exit;
+                             end;
+                             is_register(actasmpattern, token);
+                             is_asmoperator(actasmpattern,token);
+                             is_asmdirective(actasmpattern,token);
+                             { 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;
+           { override operator... not supported }
+           '&':       begin
+                         Message(assem_w_override_op_not_supported);
+                         c:=asmgetchar;
+                         gettoken := AS_NONE;
+                      end;
+           { string or character }
+           '''' :
+                      begin
+                         actasmpattern:='';
+                         while true do
+                         begin
+                           if c = '''' then
+                           begin
+                              c:=asmgetchar;
+                              if c=newline then
+                              begin
+                                 Message(scan_f_string_exceeds_line);
+                                 break;
+                              end;
+                              repeat
+                                  if c=''''then
+                                   begin
+                                       c:=asmgetchar;
+                                       if c='''' then
+                                        begin
+                                               actasmpattern:=actasmpattern+'''';
+                                               c:=asmgetchar;
+                                               if c=newline then
+                                               begin
+                                                    Message(scan_f_string_exceeds_line);
+                                                    break;
+                                               end;
+                                        end
+                                        else break;
+                                   end
+                                   else
+                                   begin
+                                          actasmpattern:=actasmpattern+c;
+                                          c:=asmgetchar;
+                                          if c=newline then
+                                            begin
+                                               Message(scan_f_string_exceeds_line);
+                                               break
+                                            end;
+                                   end;
+                              until false; { end repeat }
+                           end
+                           else break; { end if }
+                         end; { end while }
+                   token:=AS_STRING;
+                   gettoken := token;
+                   exit;
+                 end;
+           { string or character }
+           '"' :
+                      begin
+                         actasmpattern:='';
+                         while true do
+                         begin
+                           if c = '"' then
+                           begin
+                              c:=asmgetchar;
+                              if c=newline then
+                              begin
+                                 Message(scan_f_string_exceeds_line);
+                                 break;
+                              end;
+                              repeat
+                                  if c='"'then
+                                   begin
+                                       c:=asmgetchar;
+                                       if c='"' then
+                                        begin
+                                               actasmpattern:=actasmpattern+'"';
+                                               c:=asmgetchar;
+                                               if c=newline then
+                                               begin
+                                                  Message(scan_f_string_exceeds_line);
+                                                  break;
+                                               end;
+                                        end
+                                       else break;
+
+                                   end
+                                  else
+                                   begin
+                                          actasmpattern:=actasmpattern+c;
+                                          c:=asmgetchar;
+                                          if c=newline then
+                                            begin
+                                               Message(scan_f_string_exceeds_line);
+                                               break
+                                            end;
+                                   end;
+                              until false; { end repeat }
+                           end
+                           else break; { end if }
+                         end; { end while }
+                   token := AS_STRING;
+                   gettoken := token;
+                   exit;
+                 end;
+           '$' :  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;
+           ',' : begin
+                   gettoken := AS_COMMA;
+                   c:=asmgetchar;
+                   exit;
+                 end;
+           '[' : begin
+                   gettoken := AS_LBRACKET;
+                   c:=asmgetchar;
+                   exit;
+                 end;
+           ']' : begin
+                   gettoken := AS_RBRACKET;
+                   c:=asmgetchar;
+                   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_DOT;
+                   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
+                   gettoken := AS_SLASH;
+                   c:=asmgetchar;
+                   exit;
+                 end;
+           '0'..'9': begin
+                          { this flag indicates if there was an error  }
+                          { if so, then we use a default value instead.}
+                          errorflag := false;
+                          actasmpattern := c;
+                          c := asmgetchar;
+                          { Get the possible characters }
+                          while c in ['0'..'9','A'..'F','a'..'f'] do
+                          begin
+                            actasmpattern := actasmpattern + c;
+                            c:= asmgetchar;
+                          end;
+                          { Get ending character }
+                          uppervar(actasmpattern);
+                          c:=upcase(c);
+                          { possibly a binary number. }
+                          if (actasmpattern[length(actasmpattern)] = 'B') and (c <> 'H') then
+                          Begin
+                                  { Delete the last binary specifier }
+                                  delete(actasmpattern,length(actasmpattern),1);
+                                  for j:=1 to length(actasmpattern) do
+                                   if not (actasmpattern[j] in ['0','1']) then
+                                   begin
+                                       Message1(assem_e_error_in_binary_const,actasmpattern);
+                                       errorflag := TRUE;
+                                   end;
+                                 { if error, then suppose a binary value of zero. }
+                                 if errorflag then
+                                   actasmpattern := '0';
+                                 gettoken := AS_BINNUM;
+                                 exit;
+                          end
+                          else
+                          Begin
+                             case c of
+                              'O': Begin
+                                      for j:=1 to length(actasmpattern) do
+                                        if not (actasmpattern[j] in ['0'..'7']) then
+                                        begin
+                                          Message1(assem_e_error_in_octal_const,actasmpattern);
+                                          errorflag := TRUE;
+                                        end;
+                                 { if error, then suppose an octal value of zero. }
+                                     if errorflag then
+                                        actasmpattern := '0';
+                                      gettoken := AS_OCTALNUM;
+                                      c := asmgetchar;
+                                      exit;
+                                    end;
+                              'H': Begin
+                                      for j:=1 to length(actasmpattern) do
+                                        if not (actasmpattern[j] in ['0'..'9','A'..'F']) then
+                                        begin
+                                          Message1(assem_e_error_in_hex_const,actasmpattern);
+                                          errorflag := TRUE;
+                                        end;
+                                 { if error, then suppose an hex value of zero. }
+                                     if errorflag then
+                                        actasmpattern := '0';
+                                     gettoken := AS_HEXNUM;
+                                     c := asmgetchar;
+                                     exit;
+                                   end;
+                              else { must be an integer number }
+                               begin
+                                    for j:=1 to length(actasmpattern) do
+                                     if not (actasmpattern[j] in ['0'..'9']) then
+                                     begin
+                                         Message1(assem_e_error_in_integer_const,actasmpattern);
+                                         errorflag := TRUE;
+                                     end;
+                                 { if error, then suppose an int value of zero. }
+                                     if errorflag then
+                                        actasmpattern := '0';
+                                     gettoken := AS_INTNUM;
+                                     exit;
+                              end;
+                          end; { end case }
+                      end; { end if }
+                     end;
+    ';','{',#13,newline : begin
+                            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                         }
+  {---------------------------------------------------------------------}
+
+   { 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 ConcatLabeledInstr(var instr: TInstruction);
+    Begin
+       if (instr.getinstruction 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 (instr.operands[1].operandtype = OPR_LABINSTR) and
+         (instr.numops = 1) then
+           if assigned(instr.operands[1].hl) then
+            ConcatLabel(p,instr.getinstruction, instr.operands[1].hl)
+           else
+            Message(assem_f_internal_error_in_findtype);
+       end
+       else if instr.getinstruction = A_MOV then
+       Begin
+         { MOV to rel8 }
+       end
+       else
+        Message(assem_e_invalid_operand);
+    end;
+
+
+
+
+   Procedure HandleExtend(var instr: TInstruction);
+   { Handles MOVZX, MOVSX ... }
+   var
+     instruc: tasmop;
+     opsize: topsize;
+   Begin
+      instruc:=instr.getinstruction;
+      { return the old types ..}
+      { these tokens still point to valid intel strings, }
+      { but we must convert them to TRUE intel tokens    }
+      if instruc in [A_MOVSB,A_MOVSBL,A_MOVSBW,A_MOVSWL] then
+        instruc := A_MOVSX;
+      if instruc in [A_MOVZB,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)
+              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)
+              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 instr = Lxxx with a 16bit offset, we emit an error.        }
+  {       If the instruction is INS,IN,OUT,OUTS,RCL,ROL,RCR,ROR,        }
+  {        SAL,SAR,SHL,SHR,SHLD,SHRD,DIV,IDIV,BT,BTC,BTR,BTS,INT,       }
+  {        RET,ENTER,SCAS,CMPS,STOS,LODS,FNSTSW,FSTSW.                  }
+  {         set up the optypes variables manually, as well as setting   }
+  {         operand sizes.                                              }
+  { Second pass:                                                        }
+  {  Check if the combination of opcodes and operands are valid, using  }
+  {  the opcode table.                                                  }
+  { Third pass:                                                         }
+  {    If there was no error on the 2nd pass  , then we check the       }
+  {    following:                                                       }
+  {    - If this is a 0 operand opcode                                  }
+  {        we verify if it is a string opcode, if so we emit a size also}
+  {        otherwise simply emit the opcode by itself.                  }
+  {    - If this is a 1 operand opcode, and it is a reference, we make  }
+  {      sure that the operand size is valid; we emit the opcode.       }
+  {    - If this is a two operand opcode                                }
+  {      o if the opcode is MOVSX or MOVZX then we handle it specially  }
+  {      o we check the operand types (most important combinations):    }
+  {            if reg,reg we make sure that both registers are of the   }
+  {             same size.                                              }
+  {            if reg,ref or ref,reg we check if the symbol name is     }
+  {             assigned, if so a size must be specified and compared   }
+  {             to the register size, both must be equal. If there is   }
+  {             no symbol name, then we check :                         }
+  {                if refsize = NO_SIZE then OPCODE_SIZE = regsize      }
+  {                  else if refsize = regsize then OPCODE_SIZE = regsize}
+  {                   else error.                                       }
+  {                   if no_error emit the opcode.                      }
+  {            if ref,const or const,ref if ref does not have any size  }
+  {              then error, otherwise emit the opcode.                 }
+  {    - 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[1].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.    }
+       if instruc = A_FST then
+       Begin
+       end
+       else
+       if instruc = A_FILD then
+       Begin
+       end
+       else
+       if instruc = A_FLD then
+       Begin
+            {A_FLDS,A_FLDL,A_FLDT}
+       end
+       else
+       if instruc = A_FIST then
+       Begin
+            {A_FISTQ,A_FISTS,A_FISTL}
+       end
+       else
+       if instruc = A_FWAIT then
+        FWaitWarning
+       else
+       if instruc = A_MOVSX then
+       Begin
+         { change the instruction to conform to GAS }
+         if operands[1].size = S_W then
+         Begin
+             addinstr(A_MOVSBW)
+         end
+         else
+         if operands[1].size = S_L then
+         Begin
+             if operands[2].size = S_B then
+                addinstr(A_MOVSBL)
+             else
+                addinstr(A_MOVSWL);
+         end;
+         instruc := getinstruction; { reload instruction }
+       end
+       else
+       if instruc = A_MOVZX then
+       Begin
+         { change the instruction to conform to GAS }
+         if operands[1].size = S_W then
+         Begin
+             addinstr(A_MOVZB)
+         end
+         else
+         if operands[1].size = S_L then
+         Begin
+             if operands[2].size = S_B then
+                addinstr(A_MOVZB)
+             else
+                addinstr(A_MOVZWL);
+         end;
+         instruc := getinstruction; { reload instruction }
+       end
+       else
+       if (instruc in [A_BT,A_BTC,A_BTR,A_BTS]) then
+       Begin
+          if numops = 2 then
+            Begin
+                if (operands[2].operandtype = OPR_CONSTANT)
+                and (operands[2].val <= $ff) then
+                  Begin
+                     operands[2].opinfo := ao_imm8;
+                     { no operand size if using constant. }
+                     operands[2].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_IN,A_INS]) 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_IN) then
+                    Begin
+                       operands[1].opinfo := ao_acc;
+                    end
+               end
+              else
+              if (operands[2].operandtype = OPR_CONSTANT) and (operands[2].val <= $ff)
+                and (instruc = A_IN) 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_IN) then
+                    Begin
+                       operands[1].opinfo := ao_acc;
+                    end
+                end;
+            end
+          else
+            if not ((numops=0) and (instruc=A_INS)) then
+             Begin
+               Message(assem_e_invalid_opcode_and_operand);
+               exit;
+             end;
+       end
+       else
+       if (instruc in [A_OUT,A_OUTS]) 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_OUT) then
+                     Begin
+                       operands[2].opinfo := ao_acc;
+                       fits := TRUE;
+                     end
+               end
+              else
+              if (operands[1].operandtype = OPR_CONSTANT) and (operands[1].val <= $ff)
+                and (instruc = A_OUT) 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_OUT) then
+                     Begin
+                       operands[2].opinfo := ao_acc;
+                       fits := TRUE;
+                     end
+                end;
+            end
+          else
+            if not ((numops=0) and (instruc=A_OUTS)) then
+             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[2].operandtype = OPR_REGISTER) and (operands[2].reg = R_CL)
+              then
+              Begin
+                operands[2].opinfo := ao_shiftcount
+              end
+              else
+              if (operands[2].operandtype = OPR_CONSTANT) and
+                (operands[2].val <= $ff) then
+                Begin
+                   operands[2].opinfo := ao_imm8;
+                   operands[2].size := S_B;
+                end;
+            end
+          else { if numops = 2 }
+            Begin
+                Message(assem_e_invalid_opcode_and_operand);
+                exit;
+            end;
+       end
+       { endif ROL,RCL ... }
+       else
+       if instruc in [A_DIV, A_IDIV] then
+       Begin
+          if (operands[1].operandtype = OPR_REGISTER) and
+            (operands[1].reg in [R_AL,R_AX,R_EAX]) then
+                operands[1].opinfo := ao_acc;
+       end
+       else
+       if (instruc = A_FNSTSW) or (instruc = A_FSTSW) then
+       Begin
+          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[1].operandtype = OPR_REFERENCE) and
+                 (assigned(operands[1].ref.symbol)) then
+                 Freemem(operands[1].ref.symbol,length(operands[1].ref.symbol^)+1);
+               if (operands[2].operandtype = OPR_REFERENCE) and
+                 (assigned(operands[2].ref.symbol)) then
+                 Freemem(operands[2].ref.symbol,length(operands[1].ref.symbol^)+1);
+               operands[1].operandtype := OPR_NONE;
+               operands[2].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;
+
+
+
+    { swap the destination and source }
+    { to put in AT&T style direction  }
+    { only if there are 2/3 operand   }
+    { numbers.                        }
+    if (instruc <> A_ENTER) then
+       SwapOperands(instr);
+    { 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;
+
+
+    { this makes cpu.pp uncompilable, but i think this code should be }
+    { inserted in the system unit anyways.                            }
+    if (instruc >= lastop_in_table) and
+       ((cs_compilesystem in aktswitches) or (opt_processors > globals.i386)) then
+      begin
+         Message(assem_w_opcode_not_in_table);
+         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
+                 { swap the destination and source }
+                 { to put in AT&T style direction  }
+{ What does this mean !!!! ???????????????????????? }
+{                 if (output_format in [of_o,of_att]) then }
+                 { ???????????? }
+{                          SwapOperands(instr); }
+                 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;
+    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.                                                        }
+               { Even though normally gas should not be trusted, v2.8.1       }
+               { has been *extensively* tested to assure that the output      }
+               { is indeed correct with the following opcodes: push,pop,inc,dec}
+               { neg and not.                                                   }
+           OPR_REGISTER:  p^.concat(new(pai386,op_reg(instruc,
+                            S_NO,instr.operands[1].reg)));
+               { this is where it gets a bit more complicated...              }
+           OPR_REFERENCE:
+                          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] 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;
+           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     }
+                   OPR_REGISTER:
+                     Begin
+                       case operands[2].operandtype of
+                         OPR_REGISTER:
+                            { see info in ratti386.pas, about the problem }
+                            { which can cause gas here.                   }
+                            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
+                            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 (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 }
+                              { possiblities:1) local variable which }
+                              { has been replaced by bp and offset   }
+                              { in this case size should be valid    }
+                              {              2) Indirect register    }
+                              { adressing, 1st operand determines    }
+                              { size.                                }
+                              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;
+                       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
+                              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 (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 (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);
+                                    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;
+
+  {---------------------------------------------------------------------}
+  {                     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 findoverride(const s: string; var reg:tregister): boolean;
+   var
+    i: byte;
+   begin
+     findoverride := FALSE;
+     reg := R_NO;
+     for i:=0 to _count_asmoverrides do
+     Begin
+       if s = _asmoverrides[i] then
+       begin
+          reg := _overridetokens[i];
+          findoverride := TRUE;
+          exit;
+       end;
+     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;
+   Begin
+     findopcode := A_NONE;
+     for i:=firstop to lastop do
+       if  s = iasmops^[i] then
+       begin
+          findopcode:=i;
+          exit;
+       end;
+     { not found yet, 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;
+         'D': instr.stropsize := S_L;
+         'W': instr.stropsize := S_W;
+         end;
+         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 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 any token after the closing      }
+  {         RBRACKET                                                    }
+  { 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 := '';
+    { tell tokenizer that we are in }
+    { an expression.                }
+    inexpression := TRUE;
+    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;
+      { End of reference }
+      AS_RBRACKET: Begin
+                     if not ErrorFlag then
+                        BuildRefExpression := CalculateExpression(expr)
+                     else
+                        BuildRefExpression := 0;
+                     Consume(AS_RBRACKET);
+                     { no longer in an expression }
+                     inexpression := FALSE;
+                     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 BuildRecordOffset(var instr: TInstruction; varname: string);
+  {*********************************************************************}
+  { PROCEDURE BuildRecordOffset(var Instr: TInstruction)                }
+  { Description: This routine takes care of field specifiers of records }
+  {  and/or variables in asm operands. It updates the offset accordingly}
+  {*********************************************************************}
+  { ENTRY: On entry the token should be DOT.                            }
+  {    name: should be the name of the variable to be expanded. '' if   }
+  {     no variabled specified.                                         }
+  { EXIT:  On Exit the token points to SEPARATOR or COMMA.              }
+  { ERROR RECOVERY: Tries to find COMMA or SEPARATOR token by consuming }
+  {  invalid tokens.                                                    }
+  {*********************************************************************}
+  var
+    firstpass: boolean;
+    offset: longint;
+    basetypename : string;
+  Begin
+    basetypename := '';
+    firstpass := TRUE;
+    { // .ID[REG].ID ...   // }
+    { // .ID.ID...         // }
+    Consume(AS_DOT);
+    Repeat
+      case actasmtoken of
+        AS_ID: Begin
+                  InitAsmRef(instr);
+                  { // var_name.typefield.typefield // }
+                  if (varname <> '') then
+                  Begin
+                    if not GetVarOffset(varname,actasmpattern,offset) then
+                    Begin
+                      Message1(assem_e_unknown_id,actasmpattern);
+                    end
+                    else
+                      Inc(instr.operands[operandnum].ref.offset,Offset);
+                  end
+                  else
+                 {    [ref].var_name.typefield.typefield ...                }
+                 {    [ref].var_name[reg]                                   }
+                  if not assigned(instr.operands[operandnum].ref.symbol) and
+                    firstpass then
+                  Begin
+                     if not CreateVarInstr(instr,actasmpattern,operandnum) then
+                     Begin
+                       { type field ? }
+                       basetypename := actasmpattern;
+                     end
+                     else
+                       varname := actasmpattern;
+                    end
+                  else
+                  if firstpass then
+                 {    [ref].typefield.typefield ...                         }
+                 {    where the first typefield must specifiy the base      }
+                 {    object or record type.                                }
+                  Begin
+                     basetypename := actasmpattern;
+                  end
+                  else
+                 {    [ref].typefield.typefield ...                         }
+                 {  basetpyename is already set up... now look for fields.  }
+                  Begin
+                     if not GetTypeOffset(basetypename,actasmpattern,Offset) then
+                     Begin
+                      Message1(assem_e_unknown_id,actasmpattern);
+                     end
+                     else
+                       Inc(instr.operands[operandnum].ref.offset,Offset);
+                  end;
+                  Consume(AS_ID);
+                 { Take care of index register on this variable }
+                 if actasmtoken = AS_LBRACKET then
+                 Begin
+                   Consume(AS_LBRACKET);
+                   Case actasmtoken of
+                     AS_REGISTER: Begin
+                                   if instr.operands[operandnum].ref.index <> R_NO then
+                                    Message(assem_e_defining_index_more_than_once);
+                                   instr.operands[operandnum].ref.index :=
+                                      findregister(actasmpattern);
+                                   Consume(AS_REGISTER);
+                                  end;
+                    else
+                     Begin
+                      { add offsets , assuming these are constant expressions... }
+                      Inc(instr.operands[operandnum].ref.offset,BuildRefExpression);
+                     end;
+                   end;
+                   Consume(AS_RBRACKET);
+                 end;
+                 { Here we should either have AS_DOT, AS_SEPARATOR or AS_COMMA }
+                 if actasmtoken = AS_DOT then
+                    Consume(AS_DOT);
+                 firstpass := FALSE;
+                 Offset := 0;
+              end;
+        AS_SEPARATOR: exit;
+        AS_COMMA: exit;
+      else
+       Begin
+         Message(assem_e_invalid_field_specifier);
+         Consume(actasmtoken);
+         firstpass := FALSE;
+       end;
+      end; { end case }
+    Until (actasmtoken = AS_SEPARATOR) or (actasmtoken = AS_COMMA);
+  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 := '';
+    { tell tokenizer that we are in an expression. }
+    inexpression := TRUE;
+    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;
+                  inexpression := FALSE;
+                  Exit;
+               end;
+      { go to next symbol }
+      AS_SEPARATOR: Begin
+                      if not ErrorFlag then
+                        BuildExpression := CalculateExpression(expr)
+                      else
+                        BuildExpression := 0;
+                      inexpression := FALSE;
+                      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 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 AS_STAR token.                }
+  {*********************************************************************}
+  var str:string;
+      l: longint;
+      code: integer;
+  Begin
+     Consume(AS_STAR);
+     if (instr.operands[operandnum].ref.scalefactor <> 0)
+     and (instr.operands[operandnum].ref.scalefactor <> 1) then
+     Begin
+         Message(assem_f_internal_error_in_buildscale);
+     end;
+     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);
+    case actasmtoken of
+        { //  [...*SCALING-expr] ... // }
+        AS_MINUS: Begin
+                    if instr.operands[operandnum].ref.offset <> 0 then
+                     Message(assem_f_internal_error_in_buildscale);
+                    instr.operands[operandnum].ref.offset :=
+                        BuildRefExpression;
+                  end;
+        { //  [...*SCALING+expr] ... // }
+        AS_PLUS: Begin
+                    if instr.operands[operandnum].ref.offset <> 0 then
+                     Message(assem_f_internal_error_in_buildscale);
+                    instr.operands[operandnum].ref.offset :=
+                         BuildRefExpression;
+                    end;
+        { //  [...*SCALING] ... // }
+        AS_RBRACKET: Consume(AS_RBRACKET);
+    else
+       Message(assem_e_invalid_scaling_value);
+    end;
+    { // .Field.Field ... or separator/comma // }
+    Case actasmtoken of
+     AS_DOT: BuildRecordOffset(instr,'');
+     AS_COMMA, AS_SEPARATOR: ;
+    else
+      Message(assem_e_syntax_error);
+    end;
+  end;
+
+
+
+  Procedure BuildReference(var instr: TInstruction);
+  {*********************************************************************}
+  { EXIT CONDITION:  On exit the routine should point to either the     }
+  {       AS_COMMA or AS_SEPARATOR token.                               }
+  {   On entry: contains the register after the opening bracket if any. }
+  {*********************************************************************}
+  var
+    reg:string;
+    segreg: boolean;
+    negative: boolean;
+    expr: string;
+  Begin
+     expr := '';
+     if instr.operands[operandnum].operandtype <> OPR_REFERENCE then
+     Begin
+       Message(assem_e_syn_no_ref_with_brackets);
+       InitAsmRef(instr);
+       consume(AS_REGISTER);
+     end
+     else
+     Begin
+       { save the reg }
+       reg := actasmpattern;
+       { is the syntax of the form: [REG:REG...] }
+       consume(AS_REGISTER);
+       if actasmtoken = AS_COLON then
+       begin
+         segreg := TRUE;
+         Message(assem_e_expression_form_not_supported);
+         if instr.operands[operandnum].ref.segment <> R_NO then
+          Message(assem_e_defining_seg_more_than_once);
+         instr.operands[operandnum].ref.segment := findsegment(reg);
+         { Here we should process the syntax of the form   }
+         { [reg:reg...]                                    }
+         {!!!!!!!!!!!!!!!!!!!!!!!!                         }
+       end
+       { This is probably of the following syntax: }
+       { SREG:[REG...] where SReg: is optional.    }
+       { Therefore we immediately say that reg     }
+       { is the base.                              }
+       else
+       Begin
+         if instr.operands[operandnum].ref.base <> R_NO then
+          Message(assem_e_defining_base_more_than_once);
+         instr.operands[operandnum].ref.base := findregister(reg);
+       end;
+       { we process this type of syntax immediately... }
+       case actasmtoken of
+
+          { //  REG:[REG].Field.Field ...     // }
+          { //  REG:[REG].Field[REG].Field... // }
+         AS_RBRACKET: Begin
+                       Consume(AS_RBRACKET);
+                       { check for record fields }
+                       if actasmtoken = AS_DOT then
+                          BuildRecordOffset(instr,'');
+                       if (actasmtoken = AS_SEPARATOR) or (actasmtoken = AS_COMMA) then
+                         exit
+                       else
+                         Message(assem_e_syn_reference);
+                     end;
+          { //  REG:[REG +/- ...].Field.Field ... // }
+         AS_PLUS,AS_MINUS: Begin
+                            if actasmtoken = AS_MINUS then
+                            Begin
+                               expr := '-';
+                               negative := TRUE
+                            end
+                            else
+                            Begin
+                               negative := FALSE;
+                               expr := '+';
+                            end;
+                            Consume(actasmtoken);
+                            { // REG:[REG+REG+/-...].Field.Field // }
+                            if actasmtoken = AS_REGISTER then
+                            Begin
+                              if negative then
+                                Message(assem_e_negative_index_register);
+                              if instr.operands[operandnum].ref.index <> R_NO then
+                                Message(assem_e_defining_index_more_than_once);
+                              instr.operands[operandnum].ref.index := findregister(actasmpattern);
+                              Consume(AS_REGISTER);
+                              case actasmtoken of
+                                AS_RBRACKET: { // REG:[REG+REG].Field.Field... // }
+                                            Begin
+                                              Consume(AS_RBRACKET);
+                                              Case actasmtoken of
+                                                 AS_DOT: BuildRecordOffset(instr,'');
+                                                 AS_COMMA,AS_SEPARATOR: exit;
+                                              else
+                                                Message(assem_e_syntax_error);
+                                              end
+                                             end;
+                                AS_PLUS,AS_MINUS: { // REG:[REG+REG+/-expr].Field.Field... // }
+                                                Begin
+                                                  if instr.operands[operandnum].ref.offset <> 0 then
+                                                   Message(assem_f_internal_error_in_buildreference);
+                                                  instr.operands[operandnum].ref.offset :=
+                                                      BuildRefExpression;
+                                                  case actasmtoken of
+                                                    AS_DOT: BuildRecordOffset(instr,'');
+                                                    AS_COMMA,AS_SEPARATOR: ;
+                                                  else
+                                                    Message(assem_e_syntax_error);
+                                                  end; { end case }
+                                                end;
+                                AS_STAR: Begin  { // REG:[REG+REG*SCALING...].Field.Field... // }
+                                             BuildScaling(instr);
+                                         end;
+                                else
+                                Begin
+                                  Message(assem_e_syntax_error);
+                                end;
+                              end; { end case }
+                            end
+                            else if actasmtoken = AS_STAR then
+                            { // REG:[REG*SCALING ... ]     // }
+                            Begin
+                              BuildScaling(instr);
+                            end
+                            else
+                            { // REG:[REG+expr].Field.Field // }
+                             Begin
+                               if instr.operands[operandnum].ref.offset <> 0 then
+                                Message(assem_f_internal_error_in_buildreference);
+                               instr.operands[operandnum].ref.offset := BuildRefExpression;
+                               case actasmtoken of
+                                  AS_DOT: BuildRecordOffset(instr,'');
+                                  AS_COMMA,AS_SEPARATOR: ;
+                                else
+                                  Message(assem_e_syntax_error);
+                               end; { end case }
+                             end; { end if }
+                         end; { end this case }
+     { //  REG:[REG*scaling] ... // }
+         AS_STAR: Begin
+                     BuildScaling(instr);
+                 end;
+       end;
+     end; { end outer if }
+  end;
+
+
+  Procedure BuildBracketExpression(var Instr: TInstruction; var_prefix: boolean);
+  {*********************************************************************}
+  { PROCEDURE BuildBracketExpression                                    }
+  {  Description: This routine builds up an expression after a LBRACKET }
+  {  token is encountered.                                              }
+  {   On entry actasmtoken should be equal to AS_LBRACKET.              }
+  {  var_prefix : Should be set to true if variable identifier has      }
+  {    been defined, such as in ID[                                     }
+  {*********************************************************************}
+  { EXIT CONDITION:  On exit the routine should point to either the     }
+  {       AS_COMMA or AS_SEPARATOR token.                               }
+  {*********************************************************************}
+  var
+    l:longint;
+  Begin
+     Consume(AS_LBRACKET);
+     initAsmRef(instr);
+     Case actasmtoken of
+         { // Constant reference expression OR variable reference expression // }
+         AS_ID: Begin
+                if actasmpattern[1] = '@' then
+                 Message(assem_e_local_symbol_not_allowed_as_ref);
+                if SearchIConstant(actasmpattern,l) then
+                 Begin
+                   { if there was a variable prefix then }
+                   { add to offset                       }
+                   If var_prefix then
+                    Begin
+                        Inc(instr.operands[operandnum].ref.offset,  BuildRefExpression);
+                    end
+                   else
+                     instr.operands[operandnum].ref.offset :=BuildRefExpression;
+                   if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then
+                      Message(assem_e_invalid_operand_in_bracket_expression);
+                 end
+                else if NOT var_prefix then
+                 Begin
+                    InitAsmRef(instr);
+                    if not CreateVarInstr(instr,actasmpattern,operandnum) then
+                     Message1(assem_e_unknown_id,actasmpattern);
+                    Consume(AS_ID);
+                   { is there a constant expression following }
+                   { the variable name?                       }
+                   if actasmtoken <> AS_RBRACKET then
+                    Begin
+                      Inc(instr.operands[operandnum].ref.offset, BuildRefExpression);
+                    end
+                   else
+                      Consume(AS_RBRACKET);
+                 end
+                 else
+                   Message1(assem_e_invalid_symbol_name,actasmpattern);
+                end;
+               { Here we handle the special case in tp where   }
+               { the + operator is allowed with reg and var    }
+               { references, such as in mov al, byte ptr [+bx] }
+         AS_PLUS: Begin
+                   Consume(AS_PLUS);
+                   Case actasmtoken of
+                     AS_REGISTER: Begin
+                                   BuildReference(instr);
+                                 end;
+                     AS_ID: Begin
+                             if actasmpattern[1] = '@' then
+                               Message(assem_e_local_symbol_not_allowed_as_ref);
+                             if SearchIConstant(actasmpattern,l) then
+                               Begin
+                                 { if there was a variable prefix then }
+                                 { add to offset                       }
+                                 If var_prefix then
+                                  Begin
+                                    Inc(instr.operands[operandnum].ref.offset,
+                                     BuildRefExpression);
+                                  end
+                                 else
+                                   instr.operands[operandnum].ref.offset :=
+                                    BuildRefExpression;
+                                 if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then
+                                   Message(assem_e_invalid_operand_in_bracket_expression);
+                               end
+                             else if NOT var_prefix then
+                               Begin
+                               InitAsmRef(instr);
+                               if not CreateVarInstr(instr,actasmpattern,operandnum) then
+                                Message1(assem_e_unknown_id,actasmpattern);
+                               Consume(AS_ID);
+                               { is there a constant expression following }
+                               { the variable name?                       }
+                                 if actasmtoken <> AS_RBRACKET then
+                                   Begin
+                                    Inc(instr.operands[operandnum].ref.offset,
+                                      BuildRefExpression);
+                                   end
+                                 else
+                                   Consume(AS_RBRACKET);
+                               end
+                             else
+                               Message1(assem_e_invalid_symbol_name,actasmpattern);
+                           end;
+                     { // Constant reference expression //  }
+                   AS_INTNUM,AS_BINNUM,AS_OCTALNUM,
+                   AS_HEXNUM: Begin
+                               { if there was a variable prefix then }
+                               { add to offset instead.              }
+                               If var_prefix then
+                                Begin
+                                  Inc(instr.operands[operandnum].ref.offset,  BuildRefExpression);
+                                end
+                               else
+                               Begin
+                                 instr.operands[operandnum].ref.offset :=BuildRefExpression;
+                               end;
+                               if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then
+                                  Message(assem_e_invalid_operand_in_bracket_expression);
+                             end;
+                    else
+                      Message(assem_e_syntax_error);
+                   end;
+                 end;
+         { // Constant reference expression //  }
+         AS_MINUS,AS_NOT,AS_LPAREN:
+                     Begin
+                       { if there was a variable prefix then }
+                       { add to offset instead.              }
+                       If var_prefix then
+                         Begin
+                              Inc(instr.operands[operandnum].ref.offset,  BuildRefExpression);
+                         end
+                        else
+                         Begin
+                           instr.operands[operandnum].ref.offset :=BuildRefExpression;
+                         end;
+                       if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then
+                          Message(assem_e_invalid_operand_in_bracket_expression);
+                     end;
+         { // Constant reference expression //  }
+         AS_INTNUM,AS_OCTALNUM,AS_BINNUM,AS_HEXNUM: Begin
+                       { if there was a variable prefix then }
+                       { add to offset instead.              }
+                       If var_prefix then
+                         Begin
+                              Inc(instr.operands[operandnum].ref.offset,  BuildRefExpression);
+                         end
+                        else
+                         Begin
+                           instr.operands[operandnum].ref.offset :=BuildRefExpression;
+                         end;
+                       if not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) then
+                          Message(assem_e_invalid_operand_in_bracket_expression);
+                   end;
+         { // Variable reference expression // }
+         AS_REGISTER: BuildReference(instr);
+     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;
+    l : longint;
+    hl: plabel;
+  Begin
+   tempstr := '';
+   expr := '';
+   case actasmtoken of
+   { // Constant expression //  }
+     AS_PLUS,AS_MINUS,AS_NOT,AS_LPAREN:
+                                  Begin
+                                     if not (instr.operands[operandnum].operandtype in [OPR_NONE,OPR_CONSTANT]) then
+                                        Message(assem_e_invalid_operand_type);
+                                     instr.operands[operandnum].operandtype := OPR_CONSTANT;
+                                     instr.operands[operandnum].val :=BuildExpression;
+                                   end;
+   { // Constant expression //  }
+     AS_STRING:   Begin
+                    if not (instr.operands[operandnum].operandtype in [OPR_NONE]) then
+                       Message(assem_e_invalid_operand_type);
+                    instr.operands[operandnum].operandtype := OPR_CONSTANT;
+                    if not PadZero(actasmpattern,4) then
+                     Message1(assem_e_invalid_string_as_opcode_operand,actasmpattern);
+                    instr.operands[operandnum].val :=
+                      ord(actasmpattern[4]) + ord(actasmpattern[3]) shl 8 +
+                       Ord(actasmpattern[2]) shl 16 + ord(actasmpattern[1])
+                        shl 24;
+                    Consume(AS_STRING);
+                    Case actasmtoken of
+                       AS_COMMA, AS_SEPARATOR: ;
+                    else
+                      Message(assem_e_invalid_string_expression);
+                    end; { end case }
+                 end;
+   { // Constant expression //  }
+     AS_INTNUM,AS_BINNUM,
+     AS_OCTALNUM,
+     AS_HEXNUM:     Begin
+                      if not (instr.operands[operandnum].operandtype in [OPR_NONE,OPR_CONSTANT]) then
+                         Message(assem_e_invalid_operand_type);
+                      instr.operands[operandnum].operandtype := OPR_CONSTANT;
+                      instr.operands[operandnum].val :=BuildExpression;
+                    end;
+   { // A constant expression, or a Variable ref. // }
+     AS_ID:  Begin
+              if actasmpattern[1] = '@' then
+              { // Label or Special symbol reference // }
+              Begin
+                 if actasmpattern = '@RESULT' then
+                   Begin
+                      InitAsmRef(instr);
+                      SetUpResult(instr,operandnum);
+                   end
+                 else
+                  if (actasmpattern = '@CODE') or (actasmpattern = '@DATA') then
+                      Message(assem_w_CODE_and_DATA_not_supported)
+                   else
+                  Begin
+                    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
+                   { is it a constant ? }
+                   if SearchIConstant(actasmpattern,l) then
+                   Begin
+                      if not (instr.operands[operandnum].operandtype in [OPR_NONE,OPR_CONSTANT]) then
+                       Message(assem_e_invalid_operand_type);
+                      instr.operands[operandnum].operandtype := OPR_CONSTANT;
+                      instr.operands[operandnum].val :=BuildExpression;
+                    end
+                   else { is it a label variable ? }
+                    Begin
+                     { // ID[ , ID.Field.Field or simple ID // }
+                     { 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
+                         { not a variable.. }
+                         { check special variables.. }
+                         if actasmpattern = 'SELF' then
+                          { special self variable }
+                         Begin
+                           if assigned(procinfo._class) then
+                             Begin
+                               instr.operands[operandnum].ref.offset := procinfo.ESI_offset;
+                               instr.operands[operandnum].ref.base := procinfo.framepointer;
+                             end
+                           else
+                             Message(assem_e_cannot_use_SELF_outside_a_method);
+                         end
+                         else
+                           Message1(assem_e_unknown_id,actasmpattern);
+                      end;
+                      expr := actasmpattern;
+                      Consume(AS_ID);
+                      case actasmtoken of
+                           AS_LBRACKET: { indexing }
+                                        BuildBracketExpression(instr,TRUE);
+                           AS_DOT: BuildRecordOffset(instr,expr);
+
+                           AS_SEPARATOR,AS_COMMA: ;
+                      else
+                           Message(assem_e_syntax_error);
+                      end;
+                     end;
+                    end;
+               end;
+            end;
+   { // 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);
+                      if actasmtoken <> AS_LBRACKET then
+                        Message(assem_e_syn_start_with_bracket)
+                      else
+                      Begin
+                        initAsmRef(instr);
+                        instr.operands[operandnum].ref.segment := findsegment(tempstr);
+                        BuildBracketExpression(instr,false);
+                      end;
+                   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;
+    { // a variable reference, register ref. or a constant reference // }
+     AS_LBRACKET: Begin
+                   BuildBracketExpression(instr,false);
+                 end;
+    { // Unsupported // }
+     AS_SEG,AS_OFFSET: Begin
+                         Message(assem_e_SEG_and_OFFSET_not_supported);
+                         Consume(actasmtoken);
+                         { error recovery }
+                         While not (actasmtoken in [AS_SEPARATOR,AS_COMMA]) do
+                           Consume(actasmtoken);
+                       end;
+     AS_SEPARATOR, AS_COMMA: ;
+    else
+      Message(assem_e_syn_opcode_operand);
+  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
+      strlength := 0; { assume it is a DB }
+      Repeat
+        Case actasmtoken of
+          AS_STRING: Begin
+                      if maxvalue = $ffff then
+                         strlength := 2
+                      else if maxvalue = $ffffffff then
+                         strlength := 4;
+                      if strlength <> 0 then
+                      { DD and DW cases }
+                      Begin
+                         if Not PadZero(actasmpattern,strlength) then
+                          Message(scan_f_string_exceeds_line);
+                      end;
+                      expr := actasmpattern;
+                      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 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);
+     if findoverride(actasmpattern,segreg) then
+     Begin
+       Consume(AS_OPCODE);
+       Message(assem_w_repeat_prefix_and_seg_override);
+     end;
+    end
+    else
+    { //  seg prefix opcode               // }
+    { //  seg opcode                      // }
+    if findoverride(actasmpattern,segreg) then
+    Begin
+      Consume(AS_OPCODE);
+      if findprefix(actasmpattern,asmtok) then
+      Begin
+     { standard opcode prefix }
+        Message(assem_w_repeat_prefix_and_seg_override);
+        if asmtok <> A_NONE then
+          instr.addprefix(asmtok);
+        Consume(AS_OPCODE);
+      end;
+    end;
+    { //  opcode                          // }
+    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);
+      { // Valid combination of segment override // }
+      if (segreg <> R_NO) and (NOT CheckOverride(segreg,instr)) then
+        Message1(assem_e_invalid_override_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;
+         { // Typecast, Constant Expression, Type Specifier // }
+         AS_DWORD,AS_BYTE,AS_WORD,AS_TBYTE,AS_QWORD: Begin
+                                  Case actasmtoken of
+                                   AS_DWORD: instr.operands[operandnum].size := S_L;
+                                   AS_WORD:  instr.operands[operandnum].size := S_W;
+                                   AS_BYTE:  instr.operands[operandnum].size := S_B;
+                                   AS_QWORD: instr.operands[operandnum].size := S_Q;
+                                   AS_TBYTE: instr.operands[operandnum].size := S_X;
+                                  end;
+                                  Consume(actasmtoken);
+                                  Case actasmtoken of
+                                  { // Reference // }
+                                  AS_PTR: Begin
+                                           initAsmRef(instr);
+                                           Consume(AS_PTR);
+                                           BuildOperand(instr);
+                                         end;
+                                  { // Possibly a typecast or a constant // }
+                                  { // expression.                       // }
+                                  AS_LPAREN: Begin
+                                              if actasmtoken = AS_ID then
+                                              Begin
+                                                { Case vartype of                }
+                                                {  LOCAL: Replace by offset and  }
+                                                {         BP in treference.      }
+                                                {  GLOBAL: Replace by mangledname}
+                                                {    in symbol of treference     }
+                                                { Check if next token = RPAREN   }
+                                                { otherwise syntax error.        }
+                                                initAsmRef(instr);
+                                                if not CreateVarInstr(instr,actasmpattern,
+                                                   operandnum) then
+                                                Begin
+                                                   Message1(assem_e_unknown_id,actasmpattern);
+                                                end;
+                                              end
+                                              else
+                                               begin
+                                                 instr.operands[operandnum].operandtype := OPR_CONSTANT;
+                                                 instr.operands[operandnum].val := BuildExpression;
+                                               end;
+                                            end;
+                                  else
+                                    BuildOperand(instr);
+                                  end; { end case }
+                            end;
+         { // Type specifier // }
+         AS_NEAR,AS_FAR: Begin
+                          if actasmtoken = AS_NEAR then
+                            Message(assem_w_near_ignored)
+                          else
+                            Message(assem_w_far_ignored);
+                          Consume(actasmtoken);
+                          if actasmtoken = AS_PTR then
+                           begin
+                             initAsmRef(instr);
+                             Consume(AS_PTR);
+                           end;
+                           BuildOperand(instr);
+                       end;
+         { // End of asm operands for this opcode // }
+         AS_SEPARATOR: ;
+         { // Constant expression // }
+         AS_LPAREN: Begin
+                      instr.operands[operandnum].operandtype := OPR_CONSTANT;
+                      instr.operands[operandnum].val := BuildExpression;
+                    end;
+       else
+         BuildOperand(instr);
+     end; { end case }
+    end; { end while }
+  end;
+
+
+  Function Assemble: Ptree;
+  {*********************************************************************}
+  { PROCEDURE Assemble;                                                 }
+  {  Description: Parses the intel assembler syntax, parsing is done    }
+  {  according to the rules in the Turbo Pascal manual.                 }
+  {*********************************************************************}
+  Var
+   hl: plabel;
+   labelptr: pasmlabel;
+  Begin
+    Message(assem_d_start_intel);
+    inexpression := FALSE;
+    firsttoken := TRUE;
+    operandnum := 0;
+    { sets up all opcode and register tables in uppercase }
+    if not _asmsorted then
+    Begin
+      SetupTables;
+      _asmsorted := TRUE;
+    end;
+    p:=new(paasmoutput,init);
+    { 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 intruction 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,'@'+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
+                     if SearchLabel(actasmpattern,hl) then
+                       ConcatLabel(p,A_LABEL, hl)
+                     else
+                       Message1(assem_e_unknown_label_identifer,actasmpattern);
+                     Consume(AS_LABEL);
+                 end;
+        AS_DW:    Begin
+                   Consume(AS_DW);
+                   BuildConstant($ffff);
+                 end;
+
+        AS_DB:   Begin
+                  Consume(AS_DB);
+                  BuildConstant($ff);
+                end;
+        AS_DD:   Begin
+                 Consume(AS_DD);
+                 BuildConstant($ffffffff);
+                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;
+    if labellist.First <> nil then
+    Begin
+      { first label }
+      if not labelptr^.emitted then
+       Message1(assem_e_unknown_local_sym,'@'+labelptr^.name^);
+      { other labels ... }
+      While (labelptr^.Next <> nil) do
+       Begin
+          labelptr := labelptr^.Next;
+          if not labelptr^.emitted then
+           Message1(assem_e_unknown_local_sym,'@'+labelptr^.name^);
+      end;
+    end;
+  end;
+  assemble := genasmnode(p);
+  labellist.done;
+  Message(assem_d_finish_intel);
+end;
+
+
+Begin
+   old_exit:=exitproc;
+   exitproc:=@rai386_exit;
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.19  1998/03/24 21:48:34  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.18  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.17  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.16  1998/03/04 17:33:56  michael
+  + Changed ifdef FPK to ifdef FPC
+
+  Revision 1.15  1998/03/03 22:38:26  peter
+    * the last 3 files
+
+  Revision 1.14  1998/03/02 01:49:15  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.13  1998/02/13 10:35:38  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.12  1998/02/12 11:50:36  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.11  1998/02/07 18:02:36  carl
+    + fwait warning for emulation
+
+  Revision 1.10  1998/01/19 03:11:40  carl
+    * bugfix number 78
+
+  Revision 1.9  1998/01/09 19:22:51  carl
+  * bugfix of __ID variable names
+
+  Revision 1.8  1997/12/09 14:00:25  carl
+  * bugfix of intr reg,reg instructions, size must always be specified
+    under gas (ref: DJGPP FAQ)
+  * bugfix of concatopcode with fits init twice!
+  + unknown instr. only poermitted when compiling system unit and/or
+    target processor > i386
+
+  Revision 1.7  1997/12/04 12:20:50  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/11/28 18:14:45  pierre
+   working version with several bug fixes
+
+  Revision 1.5  1997/11/28 15:43:20  florian
+  Fixed stack ajustment bug, 0.9.8 compiles now 0.9.8 without problems.
+
+  Revision 1.4  1997/11/28 15:31:59  carl
+  * uncommented firstop and lastop. (otherwise can cause bugs)
+
+  Revision 1.3  1997/11/28 14:26:22  florian
+  Fixed some bugs
+
+  Revision 1.2  1997/11/28 12:03:53  michael
+  Changed comment delimiters to braces, causes problems with 0.9.1
+  Changed use of ord to typecast with longint.
+  Made boolean expressions non-redundant.
+
+  Revision 1.1.1.1  1997/11/27 08:33:00  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
+
+  9th november 1997:
+   + first working version with main distribution line of FPC (CEC)
+ 12th november 1997:
+   * bugfix of CALL and JMP with symbolic references. (CEC)
+ 13th november 1997:
+   * too many bugfixes/improvements to name... (CEC)
+   * Fixed range check, line numbering, missing operand checking
+     bugs - range checking must be off to compile under tp. (CEC)
+   + speed improvement of 30% over old version with global look up tables.
+ 14th november 1997:
+   + added support for record/object offsets. (CEC)
+   * fixed bug regarding ENTER and push imm8 instruction(CEC)
+   + fixed conflicts with fpu instructions. (CEC).
+
+}

compiler/ratti386.pas

@@ -0,0 +1,3793 @@
+{
+    $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;
+
+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
+     { 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;
+    { 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.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  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).
+
+}
+

compiler/scanner.pas

@@ -0,0 +1,2311 @@
+{
+    $Id$
+    Copyright (c) 1993,97 by Florian Klaempfl
+
+    This unit implements the scanner part and handling of the switches
+
+    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 scanner;
+
+  interface
+
+    uses
+       strings,dos,cobjects,globals,symtable,systems,files,verbose,link;
+
+    const
+       id_len = 14;
+
+    type
+       ident = string[id_len];
+
+    const
+{$ifdef L_C}
+       anz_keywords = 32;
+
+       keyword : array[1..anz_keywords] of ident = (
+          'auto','break','case','char','const','continue','default','do',
+          'double','else','enum','extern','float','for','goto','if',
+          'int','long','register','return','short','signed','sizeof','static',
+          'struct','switch','typedef','union','unsigned','void','volatile',
+          'while');
+{$else}
+       anz_keywords = 71;
+
+       keyword : array[1..anz_keywords] of ident = (
+{                'ABSOLUTE',}
+                 'AND',
+                 'ARRAY','AS','ASM',
+{                'ASSEMBLER',}
+                 'BEGIN',
+                 'BREAK','CASE','CLASS',
+                 'CONST','CONSTRUCTOR','CONTINUE',
+                 'DESTRUCTOR','DISPOSE','DIV','DO','DOWNTO','ELSE','END',
+                 'EXCEPT',
+                 'EXIT',
+{                'EXPORT',}
+                 'EXPORTS',
+{                'EXTERNAL',}
+                 'FAIL','FALSE',
+{                'FAR',}
+                 'FILE','FINALLY','FOR',
+{                'FORWARD',}
+                 'FUNCTION','GOTO','IF','IMPLEMENTATION','IN',
+                 'INHERITED','INITIALIZATION',
+{                'INLINE',} {INLINE is a reserved word in TP. Why?}
+                 'INTERFACE',
+{                'INTERRUPT',}
+                 'IS',
+                 'LABEL','LIBRARY','MOD',
+{                'NEAR',}
+                 'NEW','NIL','NOT','OBJECT',
+                 'OF','ON','OPERATOR','OR','OTHERWISE','PACKED',
+                 'PROCEDURE','PROGRAM','PROPERTY',
+                 'RAISE','RECORD','REPEAT','SELF',
+                 'SET','SHL','SHR','STRING','THEN','TO',
+                 'TRUE','TRY','TYPE','UNIT','UNTIL',
+                 'USES','VAR',
+{                'VIRTUAL',}
+                 'WHILE','WITH','XOR');
+{***}
+
+       keyword_token : array[1..anz_keywords] of ttoken = (
+{                _ABSOLUTE,}
+                 _AND,
+                 _ARRAY,_AS,_ASM,
+{                _ASSEMBLER,}
+                 _BEGIN,
+                 _BREAK,_CASE,_CLASS,
+                 _CONST,_CONSTRUCTOR,_CONTINUE,
+                 _DESTRUCTOR,_DISPOSE,_DIV,_DO,_DOWNTO,
+                 _ELSE,_END,_EXCEPT,
+                 _EXIT,
+{                _EXPORT,}
+                 _EXPORTS,
+{                _EXTERNAL,}
+                 _FAIL,_FALSE,
+{                _FAR,}
+                 _FILE,_FINALLY,_FOR,
+{                _FORWARD,}
+                 _FUNCTION,_GOTO,_IF,_IMPLEMENTATION,_IN,
+                 _INHERITED,_INITIALIZATION,
+{                _INLINE,}
+                 _INTERFACE,
+{                _INTERRUPT,}
+                 _IS,
+                 _LABEL,_LIBRARY,_MOD,
+{                _NEAR,}
+                 _NEW,_NIL,_NOT,_OBJECT,
+                 _OF,_ON,_OPERATOR,_OR,_OTHERWISE,_PACKED,
+                 _PROCEDURE,_PROGRAM,_PROPERTY,
+                 _RAISE,_RECORD,_REPEAT,_SELF,
+                 _SET,_SHL,_SHR,_STRING,_THEN,_TO,
+                 _TRUE,_TRY,_TYPE,_UNIT,_UNTIL,
+                 _USES,_VAR,
+{                _VIRTUAL,}
+                 _WHILE,_WITH,_XOR);
+{$endif}
+
+    function yylex : ttoken;
+    procedure initscanner(const fn: string);
+    procedure donescanner(compiled_at_higher_level : boolean);
+
+    { the asm parser use this function getting the input }
+    function asmgetchar : char;
+
+    { this procedure is called at the end of each line }
+    { and the function does the statistics }
+    procedure write_line;
+    { this procedure must be called before starting another scanner }
+    procedure update_line;
+
+    type
+       tpreproctoken = (PP_IFDEF,PP_IFNDEF,PP_ELSE,PP_ENDIF,PP_IFOPT);
+
+       ppreprocstack = ^tpreprocstack;
+
+       tpreprocstack = object
+          t : tpreproctoken;
+          accept : boolean;
+          next : ppreprocstack;
+          name : string;
+          line_nb : longint;
+          constructor init(_t : tpreproctoken;a : boolean;n : ppreprocstack);
+          destructor done;
+       end;
+
+    var
+       pattern,orgpattern : string;
+       { true, if type declarations are parsed }
+       parse_types : boolean;
+
+    { macros }
+
+    const
+{$ifdef TP}
+       maxmacrolen = 1024;
+{$else}
+       maxmacrolen = 16*1024;
+{$endif}
+
+    type
+       tmacrobuffer = array[0..maxmacrolen-1] of char;
+
+    var
+       macropos : longint;
+       macrobuffer : ^tmacrobuffer;
+       preprocstack : ppreprocstack;
+       inputbuffer : pchar;
+       inputpointer : word;
+       s_point : boolean;
+       c : char;
+       comment_level : word;
+{this is usefull to get the write filename
+for the last instruction of an include file !}
+       Const        FileHasChanged : Boolean = False;
+
+  implementation
+
+    const
+       newline = #10;
+
+    { const
+       line_count : longint = 0; stored in tinputfile }
+
+    { used to get better line info }
+    procedure update_line;
+
+      begin
+         inc(current_module^.current_inputfile^.line_no,
+           current_module^.current_inputfile^.line_count);
+         current_module^.current_inputfile^.line_count:=0;
+      end;
+
+    procedure reload;
+
+      var
+         readsize : word;
+         i : longint;
+
+      begin
+         if filehaschanged then
+           begin
+{$ifdef EXTDEBUG}
+              writeln ('Note: Finished reading ',current_module^.current_inputfile^.name^);
+              write  (' Coming back to ');
+              current_module^.current_inputfile^.next^.write_file_line(output);
+              writeln;
+{$endif EXTDEBUG}
+              current_module^.current_inputfile:=current_module^.current_inputfile^.next;
+
+              { this was missing !}
+              c:=inputbuffer[inputpointer];
+              inc(inputpointer);
+{$ifdef EXTDEBUG}
+              write('Next 16 char "');
+              for i:=-1 to 14 do
+                write(inputbuffer[inputpointer+i]);
+              writeln('"');
+{$endif EXTDEBUG}
+              filehaschanged:=false;
+              exit;
+           end;
+         if current_module^.current_inputfile=nil then
+           internalerror(14);
+         if current_module^.current_inputfile^.filenotatend then
+           begin
+              { load the next piece of source }
+              blockread(current_module^.current_inputfile^.f,inputbuffer^,
+                current_module^.current_inputfile^.bufsize-1,readsize);
+              { check if non-empty file }
+              if readsize > 0 then
+              begin
+                { check if null character before readsize }
+                { this mixed up the scanner..             }
+                for i:=0 to (readsize-1) do
+                begin
+                 if inputbuffer[i] = #0 then
+                  Message(scan_f_illegal_char);
+                end;
+              end;
+
+              inputbuffer[readsize]:=#0;
+              c:=inputbuffer[0];
+
+              { inputpointer points always to the _next_ character to read }
+              inputpointer:=1;
+              if eof(current_module^.current_inputfile^.f) then
+                begin
+                   current_module^.current_inputfile^.filenotatend:=false;
+
+                   { if this is the main source file then EOF }
+                   if current_module^.current_inputfile^.next=nil then
+                     inputbuffer[readsize]:=#26;
+                end;
+           end
+         else
+           begin
+              current_module^.current_inputfile^.close;
+              inputbuffer:=current_module^.current_inputfile^.next^.buf;
+              inputpointer:=current_module^.current_inputfile^.next^.bufpos;
+
+              if assigned(current_module^.current_inputfile^.next) then
+                begin
+                   c:=inputbuffer[inputpointer];
+                   filehaschanged:=True;
+{$ifdef EXTDEBUG}
+                   write('Next 16 char "');
+                   for i := 0 to 15 do write(inputbuffer[inputpointer+i]);
+                     writeln('"');
+{$endif}
+                   inputbuffer[inputpointer] := #0;
+                   { if c=newline writeline is called but increment the old
+                     inputstack instead of the new one }
+                   if c=newline then
+                     begin
+                        inc(current_module^.current_inputfile^.next^.line_no);
+                        dec(current_module^.current_inputfile^.line_no);
+                     end;
+                end;
+            end;
+      end;
+
+
+    procedure write_line;
+
+      var
+         status : tcompilestatus;
+
+      begin
+{$ifdef ver0_6}
+         status.totalcompiledlines:=abslines;
+         status.currentline:=current_module^.current_inputfile^.line_no
+           +current_module^.current_inputfile^.line_count;
+         status.currentsource:=current_module^.current_inputfile^.name^+current_module^.current_inputfile^.ext^;
+         status.totallines:=0;
+{$else}
+         with status do
+           begin
+              totalcompiledlines:=abslines;
+              currentline:=current_module^.current_inputfile^.line_no
+                +current_module^.current_inputfile^.line_count;
+              currentsource:=current_module^.current_inputfile^.name^+current_module^.current_inputfile^.ext^;
+              totallines:=0;
+           end;
+{$endif}
+         if compilestatusproc(status) then
+          stop;
+         inc(current_module^.current_inputfile^.line_count);
+         lastlinepointer:=inputpointer;
+         inc(abslines);
+      end;
+
+    procedure src_comment;forward;
+
+
+    procedure nextchar;
+      begin
+        c:=inputbuffer[inputpointer];
+        inc(inputpointer);
+        if c=#0 then
+         reload;
+        if c in [#10,#13] then
+         begin
+           if (byte(inputbuffer[inputpointer])+byte(c)=23) then
+            inc(inputpointer);
+           write_line;
+           c:=newline;
+         end;
+      end;
+
+
+    procedure skipspace;
+      var
+        lastc : byte;
+      begin
+         lastc:=0;
+         while c in [' ',#9,#10,#12,#13] do
+           begin
+             nextchar;
+             if c='{' then
+              src_comment;
+           end;
+      end;
+
+
+    function is_keyword(var token : ttoken) : boolean;
+
+      var
+         m,n,k : integer;
+
+      begin
+         { there are no keywords with a length less than 2 }
+         if length(pattern)<=1 then
+           begin
+              is_keyword:=false;
+              exit;
+           end;
+
+         m:=1;
+         n:=anz_keywords;
+         while m<=n do
+           begin
+              k:=m+(n-m) shr 1;
+              if pattern=keyword[k] then
+                begin
+                   token:=keyword_token[k];
+                   is_keyword:=true;
+                   exit;
+                end
+              else if pattern>keyword[k] then m:=k+1 else n:=k-1;
+          end;
+        is_keyword:=false;
+     end;
+
+{*****************************************************************************
+                              Preprocessor
+*****************************************************************************}
+
+    function readmessage:string;
+    var
+      i : longint;
+    begin
+      i:=0;
+      repeat
+        case c of
+         '}' : break;
+         #26 : Message(scan_f_end_of_file);
+        else
+          begin
+            if (i<255) then
+             begin
+               inc(i);
+               readmessage[i]:=c;
+             end;
+          end;
+        end;
+        nextchar;
+      until false;
+      readmessage[0]:=chr(i);
+    end;
+
+    constructor tpreprocstack.init(_t : tpreproctoken;a : boolean;n : ppreprocstack);
+
+      begin
+         t:=_t;
+         accept:=a;
+         next:=n;
+      end;
+
+    destructor tpreprocstack.done;
+
+      begin
+      end;
+
+    procedure dec_comment_level;
+
+      begin
+         if cs_tp_compatible in aktswitches then
+           comment_level:=0
+         else
+           dec(comment_level);
+      end;
+
+    procedure handle_switches;
+
+      function read_string : string;
+        var
+           hs : string;
+        begin
+           hs:='';
+           while c in ['A'..'Z','a'..'z','_','0'..'9'] do
+            begin
+              hs:=hs+c;
+              nextchar;
+            end;
+           read_string:=upper(hs);
+        end;
+
+
+      function read_number : longint;
+
+        var
+           hs : string;
+           l : longint;
+           w : word;
+
+        begin
+           read_number:=0;
+           hs:='';
+           while c in ['0'..'9'] do
+             begin
+                hs:=hs+c;
+                nextchar;
+             end;
+           valint(hs,l,w);
+           read_number:=l;
+        end;
+
+      var
+         preprocpat : string;
+         preproc_token : ttoken;
+
+      function read_preproc : ttoken;
+
+{        var
+           y : ttoken;
+           code : word;
+           l : longint;
+           hs : string;
+           hp : pinputfile;
+           hp2 : pchar;}
+        label
+           preproc_exit;
+
+
+        begin
+           while c in [' ',#9,#13,#12,#10] do
+             begin
+{                if c=#10 then write_line;}
+                nextchar;
+             end;
+           case c of
+              'A'..'Z','a'..'z','_','0'..'9' :
+                   begin
+                        preprocpat:=c;
+                      nextchar;
+                      while c in ['A'..'Z','a'..'z','0'..'9','_'] do
+                        begin
+                           preprocpat:=preprocpat+c;
+                           nextchar;
+                        end;
+                      uppervar(preprocpat);
+                      read_preproc:=ID;
+                      goto preproc_exit;
+                   end;
+              '('      : begin
+                            nextchar;
+                            read_preproc:=LKLAMMER;
+                            goto preproc_exit;
+                         end;
+              ')'      : begin
+                            nextchar;
+                            read_preproc:=RKLAMMER;
+                            goto preproc_exit;
+                         end;
+              '+'      : begin
+                            nextchar;
+                              read_preproc:=PLUS;
+                            goto preproc_exit;
+                         end;
+              '-'      : begin
+                            nextchar;
+                            read_preproc:=MINUS;
+                            goto preproc_exit;
+                         end;
+              '*'      : begin
+                            nextchar;
+                            read_preproc:=STAR;
+                            goto preproc_exit;
+                         end;
+              '/'      : begin
+                            nextchar;
+                            read_preproc:=SLASH;
+                            goto preproc_exit;
+                         end;
+              '='      : begin
+                            nextchar;
+                            read_preproc:=EQUAL;
+                            goto preproc_exit;
+                         end;
+              '>'      : begin
+                            nextchar;
+                            if c='=' then
+                              begin
+                                 nextchar;
+                                 read_preproc:=GTE;
+                                 goto preproc_exit;
+                              end
+                            else
+                              begin
+                                 read_preproc:=GT;
+                                 goto preproc_exit;
+                              end;
+                         end;
+              '<'      : begin
+                            nextchar;
+                            if c='>' then
+                              begin
+                                 nextchar;
+                                 read_preproc:=UNEQUAL;
+                                 goto preproc_exit;
+                              end
+                            else if c='=' then
+                              begin
+                                 nextchar;
+                                 read_preproc:=LTE;
+                                 goto preproc_exit;
+                              end
+                            else
+                              begin
+                                 read_preproc:=LT;
+                                 goto preproc_exit;
+                              end;
+                         end;
+              #26:
+                begin
+                   update_line;
+                   Message(scan_f_end_of_file);
+                end
+              else
+                begin
+                   read_preproc:=_EOF;
+                end;
+           end;
+        preproc_exit :
+           update_line;
+        end;
+
+      procedure preproc_consume(t : ttoken);
+
+        begin
+           if t<>preproc_token then
+            Message(scan_e_preproc_syntax_error);
+           preproc_token:=read_preproc;
+        end;
+
+      function read_expr : string;forward;
+
+      function read_factor : string;
+
+        var
+           hs : string;
+           mac : pmacrosym;
+           len : byte;
+
+        begin
+           if preproc_token=ID then
+             begin
+                if preprocpat='NOT' then
+                  begin
+                     preproc_consume(ID);
+                     hs:=read_expr;
+                     if hs='0' then
+                       read_factor:='1'
+                     else
+                       read_factor:='0';
+                  end
+                else
+                  begin
+                     mac:=pmacrosym(macros^.search(hs));
+                     hs:=preprocpat;
+                     preproc_consume(ID);
+                     if assigned(mac) then
+                       begin
+                          if mac^.defined and assigned(mac^.buftext) then
+                            begin
+                               if mac^.buflen>255 then
+                                 begin
+                                    len:=255;
+                                    Message(scan_w_marco_cut_after_255_chars);
+                                 end
+                               else
+                                 len:=mac^.buflen;
+                               hs[0]:=char(len);
+                               move(mac^.buftext^,hs[1],len);
+                            end
+                          else
+                            read_factor:='';
+                       end
+                     else
+                       read_factor:=hs;
+                  end
+             end
+           else if preproc_token=LKLAMMER then
+             begin
+                preproc_consume(LKLAMMER);
+                read_factor:=read_expr;
+                preproc_consume(RKLAMMER);
+             end
+           else
+             Message(scan_e_error_in_preproc_expr);
+        end;
+
+      function read_term : string;
+
+        var
+           hs1,hs2 : string;
+
+        begin
+           hs1:=read_factor;
+           while true do
+             begin
+                if (preproc_token=ID) then
+                  begin
+                     if preprocpat='AND' then
+                       begin
+                          preproc_consume(ID);
+                          hs2:=read_factor;
+                          if (hs1<>'0') and (hs2<>'0') then
+                            hs1:='1';
+                       end
+                     else
+                       break;
+                  end
+                else
+                  break;
+             end;
+           read_term:=hs1;
+        end;
+
+      function read_simple_expr : string;
+
+        var
+           hs1,hs2 : string;
+
+        begin
+           hs1:=read_term;
+           while true do
+             begin
+                if (preproc_token=ID) then
+                  begin
+                     if preprocpat='OR' then
+                       begin
+                          preproc_consume(ID);
+                          hs2:=read_term;
+                          if (hs1<>'0') or (hs2<>'0') then
+                            hs1:='1';
+                       end
+                     else
+                       break;
+                  end
+                else
+                  break;
+             end;
+           read_simple_expr:=hs1;
+        end;
+
+      function read_expr : string;
+
+        var
+           hs1,hs2 : string;
+           b : boolean;
+           t : ttoken;
+           w : word;
+           l1,l2 : longint;
+
+        begin
+           hs1:=read_simple_expr;
+           t:=preproc_token;
+           if not(t in [EQUAL,UNEQUAL,LT,GT,LTE,GTE]) then
+             begin
+                read_expr:=hs1;
+                exit;
+             end;
+           preproc_consume(t);
+           hs2:=read_simple_expr;
+           if is_number(hs1) and is_number(hs2) then
+             begin
+                valint(hs1,l1,w);
+                valint(hs2,l2,w);
+                case t of
+                   EQUAL:
+                     b:=l1=l2;
+                   UNEQUAL:
+                     b:=l1<>l2;
+                   LT:
+                     b:=l1<l2;
+                   GT:
+                     b:=l1>l2;
+                   GTE:
+                     b:=l1>=l2;
+                   LTE:
+                     b:=l1<=l2;
+                end;
+             end
+           else
+             begin
+                case t of
+                   EQUAL:
+                     b:=hs1=hs2;
+                   UNEQUAL:
+                     b:=hs1<>hs2;
+                   LT:
+                     b:=hs1<hs2;
+                   GT:
+                     b:=hs1>hs2;
+                   GTE:
+                     b:=hs1>=hs2;
+                   LTE:
+                     b:=hs1<=hs2;
+                end;
+             end;
+           if b then
+             read_expr:='1'
+           else
+             read_expr:='0';
+       end;
+
+    procedure skip_until_pragma;
+      var
+        found : longint;
+      begin
+         found:=0;
+         repeat
+           case c of
+            #26 : Message(scan_f_end_of_file);
+    {        newline : begin
+                         write_line;
+                         found:=0;
+                       end; }
+            '{' : begin
+                    if comment_level=0 then
+                     found:=1;
+                    inc(comment_level);
+                  end;
+            '}' : begin
+                    dec_comment_level;
+                    found:=0;
+                  end;
+            '$' : begin
+                    if found=1 then
+                     found:=2;
+                  end;
+           else
+            found:=0;
+           end;
+           nextchar;
+         until (found=2);
+         update_line;
+      end;
+
+      function Is_conditional(const hs:string):boolean;
+      begin
+        Is_Conditional:=((hs='ELSE') or (hs='IFDEF') or (hs='IFNDEF') or
+                        (hs='IFOPT') or (hs='ENDIF') or (hs='ELSE') or (hs='IF'));
+      end;
+
+      var
+         path,hs : string;
+         hp : pinputfile;
+         mac : pmacrosym;
+         found : boolean;
+         ht : ttoken;
+
+      procedure popstack;
+
+        var
+           hp : ppreprocstack;
+
+        begin
+           hp:=preprocstack^.next;
+           dispose(preprocstack,done);
+           preprocstack:=hp;
+        end;
+
+      var
+         _d : dirstr;
+         _n : namestr;
+         _e : extstr;
+         hs2,
+         msg : string;
+
+      begin
+         nextchar;
+         hs:=read_string;
+         update_line;
+         Message1(scan_d_handling_switch,hs);
+         if hs='I' then
+           begin
+              skipspace;
+              hs:=c;
+              nextchar;
+              while not(c in [' ','}','*',#13,newline]) do
+                begin
+                   hs:=hs+c;
+                   nextchar;
+                   if c=#26 then Message(scan_f_end_of_file);
+                end;
+{              if c=newline then write_line;}
+              { read until end of comment }
+              while c<>'}' do
+                begin
+                   nextchar;
+                   if c=#26 then Message(scan_f_end_of_file);
+{                   if c=newline then write_line;}
+                end;
+              {
+              dec(comment_level);
+              }
+              { Initialization }
+
+              if (hs[1]='-') then
+                {exclude(aktswitches,cs_iocheck) Not yet supported.}
+                aktswitches:=aktswitches-[cs_iocheck]
+              else if (hs[1]='+') then
+                {include(aktswitches,cs_iocheck) Not supported yet.}
+                aktswitches:=aktswitches+[cs_iocheck]
+              else
+                begin
+                   fsplit(hs,_d,_n,_e);
+                   update_line;
+                   { directory where the current file is first inspected }
+                   path:=search(hs,current_module^.current_inputfile^.path^,found);
+                   if found then
+                     hp:=new(pinputfile,init(path+_d,_n,_e))
+                   else
+                     begin
+                        path:=search(hs,includesearchpath,found);
+                        hp:=new(pinputfile,init(path+_d,_n,_e));
+                     end;
+                   hp^.reset;
+                   if ioresult=0 then
+                     begin
+                        current_module^.current_inputfile^.bufpos:=inputpointer;
+                        hp^.next:=current_module^.current_inputfile;
+                        current_module^.current_inputfile:=hp;
+                        current_module^.sourcefiles.register_file(hp);
+
+                        inputbuffer:=current_module^.current_inputfile^.buf;
+                        Message1(scan_u_start_include_file,current_module^.current_inputfile^.name^);
+                        reload;
+
+                        { we have read the }
+                        { comment end      }
+                        dec_comment_level;
+                        { only warn for over one => incompatible with BP }
+                         if (comment_level>1) then
+                          Message1(scan_w_comment_level,tostr(comment_level));
+                     end
+                   else
+                     Message1(scan_f_cannot_open_includefile,_d+_n+_e);
+                end;
+           end
+         { conditional compiling ? }
+         else if Is_Conditional(hs) then
+           begin
+              while true do
+                begin
+                   if hs='ENDIF' then
+                     begin
+                        { we can always accept an ELSE }
+                        if assigned(preprocstack) then
+                          begin
+                            Message1(scan_c_endif_found,preprocstack^.name);
+                             if preprocstack^.t=PP_ELSE then
+                               popstack;
+                          end
+                        else
+                          Message(scan_e_endif_without_if);
+
+                        { now pop the condition }
+                        if assigned(preprocstack) then
+                          begin
+                             { we only use $ifdef in the stack }
+                             if (preprocstack^.t=PP_IFDEF) then
+                               popstack
+                             else
+                               Message(scan_e_too_much_endifs);
+                          end
+                       else
+                          Message(scan_e_endif_without_if);
+                     end
+                   else if hs='IFDEF' then
+                     begin
+                        skipspace;
+                        hs:=read_string;
+                        mac:=pmacrosym(macros^.search(hs));
+                        preprocstack:=new(ppreprocstack,init(PP_IFDEF,
+                          { the block before must be accepted }
+                          { the symbole must be exist and be defined }
+                          (
+                           (preprocstack=nil) or
+                            preprocstack^.accept
+                          ) and
+                           assigned(mac) and
+                           mac^.defined,
+                          preprocstack));
+                        preprocstack^.name:=hs;
+                        preprocstack^.line_nb:=current_module^.current_inputfile^.line_no;
+                        if preprocstack^.accept then
+                         Message2(scan_c_ifdef_found,preprocstack^.name,'accepted')
+                        else
+                         Message2(scan_c_ifdef_found,preprocstack^.name,'rejected');
+                     end
+                   else if hs='IFOPT' then
+                     begin
+                        skipspace;
+                        hs:=read_string;
+                        { !!!! read switch state }
+
+                        { PP_IFDEF is correct, we doesn't distinguish between }
+                        { ifopt and ifdef                                     }
+                        preprocstack:=new(ppreprocstack,init(PP_IFDEF,
+                          { the block before must be accepted }
+                          (
+                           (preprocstack=nil) or
+                            preprocstack^.accept
+                          ) and
+                          { !!!! subject to change: }
+                          false,
+                          preprocstack));
+                        preprocstack^.name:=hs;
+                        preprocstack^.line_nb:=current_module^.current_inputfile^.line_no;
+                        if preprocstack^.accept then
+                         Message2(scan_c_ifopt_found,preprocstack^.name,'accepted')
+                        else
+                         Message2(scan_c_ifopt_found,preprocstack^.name,'rejected');
+                     end
+                   else if hs='IF' then
+                     begin
+                        skipspace;
+                        { start preproc expression scanner }
+                        preproc_token:=read_preproc;
+                        hs:=read_expr;
+
+                        { PP_IFDEF is correct, we doesn't distinguish between }
+                        { if, ifopt and ifdef                                 }
+                        preprocstack:=new(ppreprocstack,init(PP_IFDEF,
+                          { the block before must be accepted }
+                          (
+                           (preprocstack=nil) or
+                            preprocstack^.accept
+                          ) and
+                          (hs<>'0'),
+                          preprocstack));
+                        preprocstack^.name:=hs;
+                        preprocstack^.line_nb:=current_module^.current_inputfile^.line_no;
+                        if preprocstack^.accept then
+                         Message2(scan_c_if_found,preprocstack^.name,'accepted')
+                        else
+                         Message2(scan_c_if_found,preprocstack^.name,'rejected');
+                     end
+                   else if hs='IFNDEF' then
+                     begin
+                        skipspace;
+                        hs:=read_string;
+                        mac:=pmacrosym(macros^.search(hs));
+                        preprocstack:=new(ppreprocstack,init(PP_IFDEF,
+                          { the block before must be accepted }
+                          (
+                           (preprocstack=nil) or
+                           preprocstack^.accept
+                          ) and
+                           not(assigned(mac) and
+                           mac^.defined),
+                          preprocstack));
+                        preprocstack^.name:=hs;
+                        preprocstack^.line_nb:=current_module^.current_inputfile^.line_no;
+                        if preprocstack^.accept then
+                         Message2(scan_c_ifndef_found,preprocstack^.name,'accepted')
+                        else
+                         Message2(scan_c_ifndef_found,preprocstack^.name,'rejected');
+                     end
+                   else if hs='ELSE' then
+                     begin
+                        if assigned(preprocstack) then
+                          begin
+                             preprocstack:=new(ppreprocstack,init(PP_ELSE,
+                             { invert }
+                             not(preprocstack^.accept) and
+                             { but only true, if only the ifdef block is }
+                             { not accepted                              }
+                             (
+                               (preprocstack^.next=nil) or
+                               (preprocstack^.next^.accept)
+                             ),
+                             preprocstack));
+                             preprocstack^.line_nb := current_module^.current_inputfile^.line_no;
+                             preprocstack^.name := preprocstack^.next^.name;
+                             if preprocstack^.accept then
+                              Message2(scan_c_else_found,preprocstack^.name,'accepted')
+                             else
+                              Message2(scan_c_else_found,preprocstack^.name,'rejected');
+                          end
+                        else
+                          Message(scan_e_endif_without_if);
+                     end
+                   else if hs='IFOPT' then
+                     begin
+                        skipspace;
+                        hs:=read_string;
+                        preprocstack:=new(ppreprocstack,init(PP_IFDEF,
+                          false,
+                          preprocstack));
+                     end;
+
+                   { accept the text ? }
+                   if (preprocstack=nil) or preprocstack^.accept then
+                     break
+                   else
+                     begin
+                       Message(scan_c_skipping_until);
+                       repeat
+                          skip_until_pragma;
+                          hs:=read_string;
+                       until Is_Conditional(hs);
+                     end;
+                end;
+           end
+         else if (hs='WAIT') then
+           begin
+              Message(scan_i_press_enter);
+              readln;
+           end
+         else if (hs='INFO') or (hs='MESSAGE') then
+           begin
+              skipspace;
+              Message1(scan_i_user_defined,readmessage);
+           end
+         else if hs='NOTE' then
+           begin
+              skipspace;
+              Message1(scan_n_user_defined,readmessage);
+           end
+         else if hs='WARNING' then
+           begin
+              skipspace;
+              Message1(scan_w_user_defined,readmessage);
+           end
+         else if hs='ERROR' then
+           begin
+              skipspace;
+              Message1(scan_e_user_defined,readmessage);
+           end
+         else if (hs='FATALERROR') or (hs='STOP') then
+           begin
+              skipspace;
+              Message1(scan_f_user_defined,readmessage);
+           end
+         else if hs='L' then
+           begin
+              skipspace;
+              hs:='';
+              while not(c in [' ','}',#9,newline,#13]) do
+                begin
+                   hs:=hs+c;
+                   nextchar;
+                   if c=#26 then Message(scan_f_end_of_file);
+                end;
+              hs:=FixFileName(hs);
+              if not path_absolute(hs) and (current_module^.current_inputfile^.path<>nil) then
+               path:=search(hs,current_module^.current_inputfile^.path^+';'+objectsearchpath,found);
+              Linker.AddObjectFile(path+hs);
+              current_module^.linkofiles.insert(hs);
+           end
+         else if hs='D' then
+           begin
+              if current_module^.in_main then
+                Message(scan_w_switch_is_global)
+              else
+                begin
+                   if c='-' then
+                    aktswitches:=aktswitches-[cs_debuginfo]
+                   else
+                    aktswitches:=aktswitches+[cs_debuginfo];
+                end;
+           end
+         else if hs='R' then
+           begin
+               if c='-' then
+                {exclude(aktswitches,cs_rangechecking) Not yet supported.}
+                aktswitches:=aktswitches-[cs_rangechecking]
+               else
+                {include(aktswitches,cs_rangechecking); Not yet supported.}
+                aktswitches:=aktswitches+[cs_rangechecking];
+           end
+         else if hs='Q' then
+           begin
+               if c='-' then
+                 {include(aktswitches,cs_check_overflow) Not yet supported.}
+                 aktswitches:=aktswitches-[cs_check_overflow]
+               else
+                 {include(aktswitches,cs_check_overflow); Not yet supported.}
+                 aktswitches:=aktswitches+[cs_check_overflow]
+           end
+         else if hs='T' then
+           begin
+               if c='-' then
+                 aktswitches:=aktswitches-[cs_typed_addresses]
+               else
+                 aktswitches:=aktswitches+[cs_typed_addresses]
+           end
+         else if hs='V' then
+           begin
+               if c='-' then
+                 aktswitches:=aktswitches-[cs_strict_var_strings]
+               else
+                 aktswitches:=aktswitches+[cs_strict_var_strings]
+           end
+         else if hs='F' then
+           begin
+               Message(scan_n_far_directive_ignored);
+           end
+         else if hs='S' then
+           begin
+              if target_info.target<>target_linux then
+                begin
+                  case c of
+                   '-' : aktswitches:=aktswitches-[cs_check_stack];
+                   '+' : aktswitches:=aktswitches+[cs_check_stack];
+                  else
+                   Message(scan_w_illegal_switch);
+                  end;
+                end
+              else
+                begin
+                   if c in ['+','-'] then
+                     Message(scan_n_stack_check_global_under_linux)
+                   else
+                     Message(scan_w_illegal_switch);
+                 end;
+           end
+         else if hs='E' then
+           begin
+              { This is a global switch which affects all units }
+              if ((current_module = main_module) and (main_module^.in_main = false)) then
+                begin
+                  case c of
+                   '-' : aktswitches:=aktswitches-[cs_fp_emulation];
+                   '+' : aktswitches:=aktswitches+[cs_fp_emulation];
+                  else
+                   Message(scan_w_illegal_switch);
+                  end;
+                end
+              else
+                Message(scan_w_switch_is_global);
+           end
+         else if hs='X' then
+           begin
+              { This is a global switch which only affects the unit/program }
+              { being compiled                                              }
+              if not (current_module^.in_main) then
+                begin
+                  case c of
+                   '-' : aktswitches:=aktswitches-[cs_extsyntax];
+                   '+' : aktswitches:=aktswitches+[cs_extsyntax];
+                  else
+                   Message(scan_w_illegal_switch);
+                  end;
+                end
+              else
+               Message(scan_w_switch_is_global);
+           end
+         else if hs='LINKLIB' then
+           begin
+             skipspace;
+             hs:=FixFileName(read_string);
+             Linker.AddLibraryFile(hs);
+             current_module^.linklibfiles.insert(hs);
+           end
+{$ifdef i386}
+         else if hs='OUTPUT_FORMAT' then
+           begin
+              { this is a global switch }
+              if current_module^.in_main then
+               Message(scan_w_switch_is_global)
+              else
+                begin
+                   skipspace;
+                   hs:=upper(read_string);
+                   if hs='NASM' then
+                     current_module^.output_format:=of_nasm
+                   else if hs='MASM' then
+                     current_module^.output_format:=of_masm
+                   else if hs='O' then
+                     current_module^.output_format:=of_o
+                   else if hs='OBJ' then
+                     current_module^.output_format:=of_obj
+                   else
+                     Message(scan_w_illegal_switch);
+                end;
+              { for use in globals }
+              output_format:=current_module^.output_format;
+           end
+{$endif}
+{$ifdef SUPPORT_MMX}
+         else if hs='MMX' then
+           begin
+               if c='-' then
+                 aktswitches:=aktswitches-[cs_mmx]
+               else
+                 aktswitches:=aktswitches+[cs_mmx];
+           end
+         else if hs='SATURATION' then
+           begin
+               if c='-' then
+                 aktswitches:=aktswitches-[cs_mmx_saturation]
+               else
+                 aktswitches:=aktswitches+[cs_mmx_saturation];
+           end
+{$endif SUPPORT_MMX}
+         else if hs='DEFINE' then
+           begin
+              skipspace;
+              hs:=read_string;
+              mac:=pmacrosym(macros^.search(hs));
+              if not assigned(mac) then
+                begin
+                   mac:=new(pmacrosym,init(hs));
+                   mac^.defined:=true;
+                   Message1(parser_m_macro_defined,mac^.name);
+                   macros^.insert(mac);
+                end
+              else
+                begin
+                   Message1(parser_m_macro_defined,mac^.name);
+                   mac^.defined:=true;
+
+                   { delete old definition }
+                   if assigned(mac^.buftext) then
+                     begin
+                        freemem(mac^.buftext,mac^.buflen);
+                        mac^.buftext:=nil;
+                     end;
+                end;
+              if support_macros then
+                begin
+                   { key words are never substituted }
+                   hs2:=pattern;
+                   pattern:=hs;
+                   if is_keyword(ht) then
+                    Message(scan_e_keyword_cant_be_a_macro);
+                   pattern:=hs2;
+
+                   skipspace;
+                   { !!!!!! handle macro params, need we this? }
+
+                   { may be a macro? }
+                   if c=':' then
+                     begin
+                        nextchar;
+                        if c='=' then
+                          begin
+                             { first char }
+                             nextchar;
+                             macropos:=0;
+                             while (c<>'}') do
+                               begin
+                                  macrobuffer^[macropos]:=c;
+{                                  if c=newline then write_line;}
+                                  nextchar;
+                                  if c=#26 then Message(scan_f_end_of_file);
+
+                                  inc(macropos);
+                                  if macropos>maxmacrolen then
+                                   Message(scan_f_macro_buffer_overflow);
+                               end;
+
+                             { free buffer of macro ?}
+                             if assigned(mac^.buftext) then
+                               freemem(mac^.buftext,mac^.buflen);
+
+                             { get new mem }
+                             getmem(mac^.buftext,macropos);
+                             mac^.buflen:=macropos;
+
+                             { copy the text }
+                             move(macrobuffer^,mac^.buftext^,macropos);
+                          end;
+                     end;
+                end;
+           end
+         else if hs='UNDEF' then
+           begin
+              skipspace;
+              hs:=read_string;
+              mac:=pmacrosym(macros^.search(hs));
+              if not assigned(mac) then
+                begin
+                   mac:=new(pmacrosym,init(hs));
+                   Message1(parser_m_macro_undefined,mac^.name);
+                   mac^.defined:=false;
+                   macros^.insert(mac);
+                end
+              else
+                begin
+                   Message1(parser_m_macro_undefined,mac^.name);
+                   mac^.defined:=false;
+                   { delete old definition }
+                   if assigned(mac^.buftext) then
+                     begin
+                        freemem(mac^.buftext,mac^.buflen);
+                        mac^.buftext:=nil;
+                     end;
+                end;
+           end
+         else if hs='PACKRECORDS' then
+           begin
+              skipspace;
+              if upcase(c)='N' then
+                begin
+                   hs:=read_string;
+                   if hs='NORMAL' then
+                     aktpackrecords:=2
+                   else
+                    Message(scan_w_only_pack_records);
+                end
+              else
+                case read_number of
+                   1 : aktpackrecords:=1;
+                   2 : aktpackrecords:=2;
+                   4 : aktpackrecords:=4;
+                   else Message(scan_w_only_pack_records);
+                end;
+           end
+{$ifdef i386}
+         else if hs='I386_INTEL' then
+           aktasmmode:=I386_INTEL
+         else if hs='I386_DIRECT' then
+           aktasmmode:=I386_DIRECT
+         else if hs='I386_ATT' then
+           aktasmmode:=I386_ATT
+{$endif}
+         else
+           begin
+              Message(scan_w_illegal_switch);
+           end;
+      end;
+
+    procedure src_comment;
+
+      begin
+         inc(comment_level);
+         { only warn for over one => incompatible with BP }
+         if (comment_level>1) then
+          Message1(scan_w_comment_level,tostr(comment_level));
+         nextchar;
+         while true do
+           begin
+              { handle compiler switches }
+              if (comment_level=1) and (c='$') then
+                handle_switches;
+              { handle_switches can dec comment_level, }
+              { if there is an include file             }
+              while (c<>'}') and (comment_level>0) do
+                begin
+                   if c='{' then
+                     src_comment
+                   else
+                     begin
+                        if c=#26 then Message(scan_f_end_of_file);
+{                        if c=newline then write_line;}
+                        nextchar;
+                     end;
+                end;
+              { this is needed for the include files      }
+              { if there is a end of comment then read it }
+              if c='}' then
+                begin
+                   nextchar;
+                   dec_comment_level;
+                   { only warn for over one => incompatible with BP }
+                   if (comment_level>1) then
+                    Message1(scan_w_comment_level,tostr(comment_level));
+                end;
+              { checks }{ }
+              if c='{' then
+                begin
+                   inc(comment_level);
+                   { only warn for over one => incompatible with BP }
+                   if (comment_level>1) then
+                    Message1(scan_w_comment_level,tostr(comment_level));
+                   nextchar;
+                end
+              else
+                break;
+           end;
+      end;
+
+    procedure delphi_comment;
+      begin
+        { C++/Delphi styled comment }
+        inc(comment_level);
+        nextchar;
+        { this is currently not supported }
+        if c='$' then
+          Message(scan_e_wrong_styled_switch);
+        while c<>newline do
+          begin
+             if c=#26 then Message(scan_f_end_of_file);
+             nextchar;
+          end;
+        dec(comment_level);
+      end;
+
+   const
+      yylexcount : longint = 0;
+
+   function yylex : ttoken;
+
+     var
+        y : ttoken;
+        code : word;
+        l : longint;
+        hs : string;
+        mac : pmacrosym;
+        hp : pinputfile;
+        hp2 : pchar;
+     label
+        yylex_exit;
+
+     begin
+        { was the last character a point ? }
+
+        { this code is needed because the scanner if there is a 1. found if  }
+        { this is a floating point number or range like 1..3                 }
+        if s_point then
+          begin
+             s_point:=false;
+             if c='.' then
+               begin
+                  nextchar;
+                  yylex:=POINTPOINT;
+                  goto yylex_exit;
+               end;
+             yylex:=POINT;
+             goto yylex_exit;
+          end;
+
+        if c='{' then src_comment;
+        skipspace;
+        lasttokenpos:=inputpointer-1;
+        case c of
+           'A'..'Z','a'..'z','_' :
+                begin
+                   orgpattern:=c;
+                   nextchar;
+                   while c in ['A'..'Z','a'..'z','0'..'9','_'] do
+                     begin
+                        orgpattern:=orgpattern+c;
+                        nextchar;
+                     end;
+                   pattern:=orgpattern;
+                   uppervar(pattern);
+                   if is_keyword(y) then
+                     yylex:=y
+                   else
+                     begin
+                        { this takes some time ... }
+                        if support_macros then
+                          begin
+                             mac:=pmacrosym(macros^.search(pattern));
+                             if assigned(mac) and (assigned(mac^.buftext)) then
+                               begin
+                                  { don't forget the last char }
+                                  dec(inputpointer);
+                                  current_module^.current_inputfile^.bufpos:=inputpointer;
+
+                                  { this isn't a proper way, but ... }
+                                  hp:=new(pinputfile,init('','Macro '+pattern,''));
+
+                                  hp^.next:=current_module^.current_inputfile;
+                                  current_module^.current_inputfile:=hp;
+                                  current_module^.sourcefiles.register_file(hp);
+
+                                  { set an own buffer }
+                                  getmem(hp2,mac^.buflen+1);
+                                  current_module^.current_inputfile^.setbuf(hp2,mac^.buflen+1);
+
+                                  inputbuffer:=current_module^.current_inputfile^.buf;
+
+                                  { copy text }
+                                  move(mac^.buftext^,inputbuffer^,mac^.buflen);
+
+                                  { put end sign }
+                                  inputbuffer[mac^.buflen+1]:=#0;
+
+                                  { load c }
+                                  c:=inputbuffer[0];
+
+                                  { point to the next char }
+                                  inputpointer:=1;
+
+                                  { handle empty macros }
+                                  if c=#0 then reload;
+
+                                  { play it again ... }
+                                  inc(yylexcount);
+                                  if yylexcount>16 then
+                                    Message(scan_w_macro_deep_ten);
+{$ifdef TP}
+                                  yylex:=yylex;
+{$else}
+                                  yylex:=yylex();
+{$endif}
+                                { that's all folks }
+                                dec(yylexcount);
+                                goto yylex_exit;
+                              end;
+                           end;
+                           yylex:=ID;
+                        end;
+                      goto yylex_exit;
+                   end;
+           '$'      : begin
+                         pattern:=c;
+                         nextchar;
+                         while ((ord(c)>=ord('0')) and (ord(c)<=ord('9'))) or
+                                (ord(upcase(c))>=ord('A')) and (ord(upcase(c))<=ord('F')) do
+                           begin
+                              pattern:=pattern+c;
+                              nextchar;
+                           end;
+                         yylex:=INTCONST;
+                         goto yylex_exit;
+                      end;
+{why ?ifdef FPC}
+{ because the tp val doesn't recognize this, }
+{ so it's useless in TP versions             }
+{ it's solved with valint                    }
+           '%'      : begin
+                         pattern:=c;
+                         nextchar;
+                         while c in ['0','1'] do
+                           begin
+                              pattern:=pattern+c;
+                              nextchar;
+                           end;
+                         yylex:=INTCONST;
+                         goto yylex_exit;
+                      end;
+{cond removed endif}
+           '0'..'9' : begin
+                         pattern:=c;
+                         nextchar;
+                         while c in ['0'..'9'] do
+                           begin
+                              pattern:=pattern+c;
+                              nextchar;
+                           end;
+                         if c in ['.','e','E'] then
+                           begin
+                              if c='.' then
+                                begin
+                                   nextchar;
+                                   if not(c in ['0'..'9']) then
+                                     begin
+                                        s_point:=true;
+                                        yylex:=INTCONST;
+                                        goto yylex_exit;
+                                     end;
+                                   pattern:=pattern+'.';
+                                   while c in ['0'..'9'] do
+                                     begin
+                                        pattern:=pattern+c;
+                                        nextchar;
+                                     end;
+                                end;
+                              if upcase(c)='E' then
+                                begin
+                                   pattern:=pattern+'E';
+                                   nextchar;
+                                   if c in ['-','+'] then
+                                     begin
+                                        pattern:=pattern+c;
+                                        nextchar;
+                                     end;
+                                   if not(c in ['0'..'9']) then
+                                     Message(scan_f_illegal_char);
+                                   while c in ['0'..'9'] do
+                                     begin
+                                        pattern:=pattern+c;
+                                        nextchar;
+                                     end;
+                                end;
+                              yylex:=REALNUMBER;
+                              goto yylex_exit;
+                           end;
+                         yylex:=INTCONST;
+                         goto yylex_exit;
+                      end;
+           ';'      : begin
+                         nextchar;
+                         yylex:=SEMICOLON;
+                         exit;
+                      end;
+           '['      : begin
+                         nextchar;
+                         yylex:=LECKKLAMMER;
+                         goto yylex_exit;
+                      end;
+           ']'      : begin
+                         nextchar;
+                         yylex:=RECKKLAMMER;
+                         goto yylex_exit;
+                      end;
+           '('      : begin
+                         nextchar;
+                         if c='*' then
+                           begin
+                              inc(comment_level);
+                              nextchar;
+                              while true do
+                                begin
+                                   { this is currently not supported }
+                                   if c='$' then
+                                    Message(scan_e_wrong_styled_switch);
+                                   repeat
+                                      while c<>'*' do
+                                        begin
+                                           if c=#26 then Message(scan_f_end_of_file);
+{                                           if c=newline then write_line;}
+                                           nextchar;
+                                        end;
+                                      if c=#26 then Message(scan_f_end_of_file);
+                                      {if c=newline then write_line;}
+                                      nextchar;
+                                   until c=')';
+                                   dec(comment_level);
+
+                                   nextchar;
+                                   { check for *)(* }
+                                   if c='(' then
+                                     begin
+                                        nextchar;
+                                        if c<>'*' then
+                                          begin
+                                             yylex:=LKLAMMER;
+                                             goto yylex_exit;
+                                          end;
+                                        inc(comment_level);
+                                        nextchar;
+                                     end
+                                   else
+                                     begin
+{$ifndef TP}
+                                        yylex:=yylex();
+{$else TP}
+                                        yylex:=yylex;
+{$endif TP}
+                                        goto yylex_exit;
+                                     end;
+                                end;
+                           end;
+                         yylex:=LKLAMMER;
+                         goto yylex_exit;
+                      end;
+
+           ')'      : begin
+                         nextchar;
+                         yylex:=RKLAMMER;
+                         goto yylex_exit;
+                      end;
+           '+'      : begin
+                         nextchar;
+                         if (c='=') and c_like_operators then
+                           begin
+                              nextchar;
+                              yylex:=_PLUSASN;
+                              goto yylex_exit;
+                           end
+                         else
+                           begin
+                              yylex:=PLUS;
+                              goto yylex_exit;
+                           end;
+                      end;
+           '-'      : begin
+                         nextchar;
+                         if (c='=') and c_like_operators then
+                           begin
+                              nextchar;
+                              yylex:=_MINUSASN;
+                              goto yylex_exit;
+                           end
+                         else
+                           begin
+                              yylex:=MINUS;
+                              goto yylex_exit;
+                           end;
+                      end;
+           ':'      : begin
+                         nextchar;
+                         if c='=' then
+                           begin
+                              nextchar;
+                              yylex:=ASSIGNMENT;
+                              goto yylex_exit;
+                           end
+                         else
+                           begin
+                              yylex:=COLON;
+                              goto yylex_exit;
+                           end;
+                      end;
+           '*'      : begin
+                         nextchar;
+                         if (c='=') and c_like_operators then
+                           begin
+                              nextchar;
+                              yylex:=_STARASN;
+                              goto yylex_exit;
+                           end
+                         else
+                           begin
+                              yylex:=STAR;
+                              goto yylex_exit;
+                           end;
+                      end;
+           '/'      : begin
+                         nextchar;
+                         if (c='=') and c_like_operators then
+                           begin
+                              nextchar;
+                              yylex:=_SLASHASN;
+                              goto yylex_exit;
+                           end
+                         else if (c='/') then
+                           begin
+                              delphi_comment;
+{$ifndef TP}
+                              yylex:=yylex();
+{$else TP}
+                              yylex:=yylex;
+{$endif TP}
+                              goto yylex_exit;
+                           end
+                         else
+                           begin
+                              yylex:=SLASH;
+                              goto yylex_exit;
+                           end;
+                      end;
+           '='      : begin
+                         nextchar;
+                         yylex:=EQUAL;
+                         goto yylex_exit;
+                      end;
+           '.'      : begin
+                         nextchar;
+                         if c='.' then
+                           begin
+                              nextchar;
+                              yylex:=POINTPOINT;
+                              goto yylex_exit;
+                           end
+                         else
+                         yylex:=POINT;
+                         goto yylex_exit;
+                      end;
+           '@'      : begin
+                         nextchar;
+                         if c='@' then
+                           begin
+                              nextchar;
+                              yylex:=DOUBLEADDR;
+                           end
+                         else
+                           yylex:=KLAMMERAFFE;
+                         goto yylex_exit;
+                      end;
+           ','      : begin
+                         nextchar;
+                         yylex:=COMMA;
+                         exit;
+                      end;
+           '''','#','^' :
+                      begin
+                         if c='^' then
+                           begin
+                              nextchar;
+                              c:=upcase(c);
+                              if not(parse_types) and (c in ['A'..'Z']) then
+                                begin
+                                   pattern:=chr(ord(c)-64);
+                                   nextchar;
+                                end
+                              else
+                                begin
+                                   yylex:=CARET;
+                                   goto yylex_exit;
+                                end;
+                           end
+                         else pattern:='';
+                         while true do
+                           case c of
+                             '#' :
+                                begin
+                                   hs:='';
+                                   nextchar;
+                                   if c='$' then
+                                     begin
+                                        hs:='$';
+                                        nextchar;
+                                        while c in (['0'..'9','a'..'f','A'..'F']) do
+                                          begin
+                                             hs:=hs+upcase(c);
+                                             nextchar;
+                                          end;
+                                     end
+                                   else
+                                   { FPC supports binary constants }
+                                   { %10101 evalutes to 37         }
+                                   if c='%' then
+                                     begin
+                                        nextchar;
+                                        while c in ['0','1'] do
+                                          begin
+                                             hs:=hs+upcase(c);
+                                             nextchar;
+                                          end;
+                                     end
+                                   else
+                                     begin
+                                        while (ord(c)>=ord('0')) and (ord(c)<=ord('9')) do
+                                          begin
+                                             hs:=hs+c;
+                                             nextchar;
+                                          end;
+                                     end;
+                                   valint(hs,l,code);
+                                   if (code<>0) or (l<0) or (l>255) then
+                                     Message(scan_e_illegal_char_const);
+                                    pattern:=pattern+chr(l);
+                                 end;
+                             '''' :
+                                begin
+                                   repeat
+                                     nextchar;
+                     case c of
+                       #26 : begin
+                               Message(scan_f_end_of_file);
+                               break;
+                             end;
+                       #13,
+                               newline : begin
+                                            Message(scan_f_string_exceeds_line);
+                                            break;
+                                         end;
+                       '''' : begin
+                                  nextchar;
+                                  if c<>'''' then
+                                      break;
+                              end;
+                   end;
+                                     pattern:=pattern+c;
+                                   until false;
+                                end;
+                             '^' : begin
+                                      nextchar;
+                                      c:=upcase(c);
+                                      if c in ['A'..'Z'] then
+                                        pattern:=pattern+chr(ord(c)-64)
+                                      else Message(scan_f_illegal_char);
+                                      nextchar;
+                                   end;
+                             else break;
+                           end;
+                         { strings with length 1 become const chars }
+                         if length(pattern)=1 then
+                           yylex:=CCHAR
+                           else yylex:=CSTRING;
+                         goto yylex_exit;
+                      end;
+           '>'      : begin
+                         nextchar;
+                         if c='=' then
+                           begin
+                              nextchar;
+                              yylex:=GTE;
+                              goto yylex_exit;
+                           end
+                         else if c='>' then
+                           begin
+                              nextchar;
+                              yylex:=_SHR;
+                              goto yylex_exit;
+                           end
+                         else if c='<' then
+                           begin
+                              nextchar;
+                              { >< is for a symetric diff for sets }
+                              yylex:=SYMDIF;
+                              goto yylex_exit;
+                           end
+                         else
+                           begin
+                              yylex:=GT;
+                              goto yylex_exit;
+                           end;
+                      end;
+           '<'      : begin
+                         nextchar;
+                         if c='>' then
+                           begin
+                              nextchar;
+                              yylex:=UNEQUAL;
+                              goto yylex_exit;
+                           end
+                         else if c='=' then
+                           begin
+                              nextchar;
+                              yylex:=LTE;
+                              goto yylex_exit;
+                           end
+                         else if c='<' then
+                           begin
+                              nextchar;
+                              yylex:=_SHL;
+                              goto yylex_exit;
+                           end
+                         else
+                           begin
+                              yylex:=LT;
+                              goto yylex_exit;
+                           end;
+                      end;
+           #26      : begin
+                         yylex:=_EOF;
+                         goto yylex_exit;
+                      end;
+           else
+             begin
+                update_line;
+                Message(scan_f_illegal_char);
+             end;
+           end;
+     yylex_exit :
+        update_line;
+     end;
+
+    const last_asmgetchar_was_a_comment : boolean = false;
+
+    function asmgetchar : char;
+      begin
+         if c='{' then
+           begin
+              src_comment;
+              { a comment is a seperator }
+              asmgetchar:=';';
+              last_asmgetchar_was_a_comment:=true;
+           end
+         else
+           begin
+              update_line;
+              if last_asmgetchar_was_a_comment then
+                begin
+                   last_asmgetchar_was_a_comment:=false;
+                   asmgetchar:=c;
+                   exit;
+                end;
+              nextchar;
+              asmgetchar:=c;
+              if c='/' then
+               begin
+                 nextchar;
+                 if c='/' then
+                  begin
+                    delphi_comment;
+                    asmgetchar:=c;
+                  end
+                 else
+                  begin
+                    last_asmgetchar_was_a_comment:=true;
+                    asmgetchar:='/';
+                  end;
+               end;
+           end;
+      end;
+
+   procedure initscanner(const fn: string);
+     var
+       d:dirstr;
+       n:namestr;
+       e:extstr;
+     begin
+        fsplit(fn,d,n,e);
+
+        current_module^.current_inputfile:=new(pinputfile,init(d,n,e));
+        current_module^.current_inputfile^.reset;
+
+        current_module^.sourcefiles.register_file(current_module^.current_inputfile);
+
+        if ioresult<>0 then
+         Message(scan_f_cannot_open_input);
+
+        inputbuffer:=current_module^.current_inputfile^.buf;
+        preprocstack:=nil;
+        reload;
+        comment_level:=0;
+        lasttokenpos:=0;
+        lastlinepointer:=0;
+        s_point:=false;
+     end;
+
+   procedure donescanner(compiled_at_higher_level : boolean);
+
+     var
+        st : string;
+
+     begin
+        if not (compiled_at_higher_level) and  assigned(preprocstack) then
+          begin
+             if preprocstack^.t=PP_IFDEF then
+               st:='$IF(N)(DEF)'
+             else
+               st:='$ELSE';
+             Message3(scan_e_endif_expected,st,preprocstack^.name,tostr(preprocstack^.line_nb));
+          end;
+     end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.43  1998/03/24 21:48:34  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.42  1998/03/10 17:19:29  peter
+    * fixed bug0108
+    * better linebreak scanning (concentrated in nextchar(), it supports
+      #10, #13, #10#13, #13#10
+
+  Revision 1.41  1998/03/10 16:27:45  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.40  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.39  1998/03/09 12:58:14  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.38  1998/03/06 00:52:52  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.37  1998/03/04 17:34:06  michael
+  + Changed ifdef FPK to ifdef FPC
+
+  Revision 1.36  1998/03/03 22:38:34  peter
+    * the last 3 files
+
+  Revision 1.35  1998/03/02 01:49:26  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.34  1998/02/26 11:57:16  daniel
+  * New assembler optimizations commented out, because of bugs.
+  * Use of dir-/name- and extstr.
+
+  Revision 1.33  1998/02/22 23:03:32  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.32  1998/02/17 21:20:59  peter
+    + Script unit
+    + __EXIT is called again to exit a program
+    - target_info.link/assembler calls
+    * linking works again for dos
+    * optimized a few filehandling functions
+    * fixed stabs generation for procedures
+
+  Revision 1.31  1998/02/16 12:51:44  michael
+  + Implemented linker object
+
+  Revision 1.30  1998/02/13 10:35:45  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.29  1998/02/12 17:19:25  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.28  1998/02/12 11:50:44  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.27  1998/02/07 09:39:27  florian
+    * correct handling of in_main
+    + $D,$T,$X,$V like tp
+
+  Revision 1.26  1998/02/05 22:27:06  florian
+    * small problems fixed: remake3 should now work
+
+  Revision 1.25  1998/02/03 22:13:35  florian
+    * clean up
+
+  Revision 1.24  1998/02/02 23:42:38  florian
+    * data is now dword aligned per default else the stack ajustements are useless
+    + $wait directive: stops compiling til return is presseed (a message is
+      also written, useful to give the user a change to notice a message
+
+  Revision 1.23  1998/02/02 13:13:28  pierre
+    * line_count transfered to tinputfile, to avoid crosscounting
+
+  Revision 1.22  1998/01/30 17:30:10  pierre
+    + better line counting mechanism
+      line count updated only when important tokens are read
+      (not for comment , ; )
+
+  Revision 1.21  1998/01/26 19:09:52  peter
+    * fixed EOF in open string constant reading
+
+  Revision 1.20  1998/01/22 08:56:55  peter
+    * Fixed string exceeds end of line problem (#13 is not a linux
+      linebreak)
+
+  Revision 1.19  1998/01/20 18:18:46  peter
+    * fixed skip_until_pragma, bug0044 and the compiler recompile good
+
+  Revision 1.18  1998/01/20 16:30:17  pierre
+    * bug with braces in log from Peter removed
+
+  Revision 1.17  1998/01/20 15:14:33  peter
+    * fixes bug 44 with multiple $'s between skipped $IFDEF and $ENDIF
+
+  Revision 1.16  1998/01/13 16:16:06  pierre
+    *  bug in interdependent units handling
+       - primary unit was not in loaded_units list
+       - current_module^.symtable was assigned too early
+       - donescanner must not call error if the compilation
+       of the unit was done at a higher level.
+
+  Revision 1.15  1998/01/09 23:08:34  florian
+    + C++/Delphi styled //-comments
+    * some bugs in Delphi object model fixed
+    + override directive
+
+  Revision 1.14  1998/01/09 18:01:17  florian
+    * VIRTUAL isn't anymore a common keyword
+    + DYNAMIC is equal to VIRTUAL
+
+  Revision 1.13  1998/01/09 13:39:57  florian
+    * public, protected and private aren't anymore key words
+    + published is equal to public
+
+  Revision 1.12  1997/12/12 13:28:41  florian
+  + version 0.99.0
+  * all WASM options changed into MASM
+  + -O2 for Pentium II optimizations
+
+  Revision 1.11  1997/12/10 23:07:30  florian
+  * bugs fixed: 12,38 (also m68k),39,40,41
+  + warning if a system unit is without -Us compiled
+  + warning if a method is virtual and private (was an error)
+  * some indentions changed
+  + factor does a better error recovering (omit some crashes)
+  + problem with @type(x) removed (crashed the compiler)
+
+  Revision 1.10  1997/12/09 14:09:15  carl
+  * bugfix of Runerror 216 when reading a null character (such as trying to
+    compile a binary file)
+
+  Revision 1.9  1997/12/08 11:51:12  pierre
+    * corrected some buggy code in hexadecimal number reading
+
+  Revision 1.8  1997/12/05 14:22:20  daniel
+  * Did some source code beutification.
+
+  Revision 1.7  1997/12/03 13:43:14  carl
+  + OUTPUT_FORMAT switch is processor specific to i386.
+
+  Revision 1.6  1997/12/02 16:00:55  carl
+  * bugfix of include files - now gives out a fatalerror if not found,
+  otherwise would create invalid pointer operations everywhere.
+  * bugfix of $i+xyz now the $i+/- switch is correctly recognized as io
+  checking and ont an include directive.
+
+  Revision 1.5  1997/11/28 18:14:48  pierre
+   working version with several bug fixes
+
+  Revision 1.4  1997/11/28 14:26:26  florian
+  Fixed some bugs
+
+  Revision 1.3  1997/11/27 17:47:14  carl
+  * fixed bug with assem switches and m68k.
+
+  Revision 1.2  1997/11/27 17:40:48  carl
+  + assem type scanning switches for intel targets.
+
+  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
+
+  History:
+       6th september 1997:
+         + added support for global switches (i.e $X and $E (for m68k)) (CEC)
+       1st october 1997:
+         + added $ifopt as dummy which is always rejected (FK)
+      13th october 1997:
+         * user defined message are now written via the errors unit
+           and exterror (FK)
+         + compiler switch $INFO added, does the same like $MESSAGE,
+           the text is written via comment(v_info,...) (FK)
+         + $STOP and $FATALERROR added: they are equivalent, the
+           following message is written and the compiler stops (FK)
+         - write_c, no more necessary (FK)
+      14th october 1997:
+         + wrong line counting corrected: <comment start> $I test
+                                          <comment end>
+           (FK)
+      17th october 1997:
+         + support of $if expr   (FK)
+         * $define a=1234 to a:=1234   (FK)
+         + -So allows now <comment start> <comment start> <comment end>
+           as comment (preocedure dec_comment_level)    (FK)
+      22th october 1997:
+         + $NOTE  (FK)
+       9th november 1997:
+          + added updating of line_no in asmgetchar. (CEC)
+      14th november 1997:
+          * fixed problem with asm line counting. (CEC)
+      17th november 1997:
+         + kommentar renamed src_comment and kommentarebene renamed comment_level (PM)
+
+}
+

compiler/script.pas

@@ -0,0 +1,219 @@
+{
+    $Id$
+    Copyright (c) 1998 by Peter Vreman
+
+    This unit handles the writing of script files
+
+    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 Script;
+interface
+
+uses
+  CObjects;
+
+type
+  PScript=^TScript;
+  TScript=object
+    fn   : string[80];
+    data : TStringQueue;
+    constructor Init(const s:string);
+    destructor Done;
+    procedure AddStart(const s:string);
+    procedure Add(const s:string);
+    Function Empty:boolean;
+    procedure WriteToDisk;virtual;
+  end;
+
+  TAsmScript = Object (TScript)
+    Constructor Init (Const ScriptName : String);
+    Procedure AddAsmCommand (Const Command, Options,FileName : String);
+    Procedure AddLinkCommand (Const Command, Options, FileName : String);
+    Procedure AddDeleteCommand (Const FileName : String);
+    Procedure WriteToDisk;virtual;
+    end;
+  PAsmScript = ^TAsmScript;
+
+{ Asm response file }
+var
+  AsmRes : TAsmScript;
+
+
+implementation
+
+uses
+{$ifdef linux}
+  linux,
+{$endif}
+  globals,systems;
+
+
+{****************************************************************************
+                                  TScript
+****************************************************************************}
+
+constructor TScript.Init(const s:string);
+begin
+  fn:=FixFileName(s)+source_info.scriptext;
+  data.Init;
+end;
+
+
+destructor TScript.Done;
+begin
+  data.done;
+end;
+
+
+procedure TScript.AddStart(const s:string);
+begin
+  data.Insert(s);
+end;
+
+
+procedure TScript.Add(const s:string);
+begin
+  data.Concat(s);
+end;
+
+
+Function TScript.Empty:boolean;
+begin
+  Empty:=Data.Empty;
+end;
+
+
+procedure TScript.WriteToDisk;
+var
+  t : Text;
+begin
+  Assign(t,fn);
+  Rewrite(t);
+  while not data.Empty do
+   Writeln(t,data.Get);
+  Close(t);
+{$ifdef linux}
+  ChMod(fn,493);
+{$endif}
+end;
+
+
+{****************************************************************************
+                                  Asm Response
+****************************************************************************}
+
+Constructor TAsmScript.Init (Const ScriptName : String);
+
+begin
+  Inherited Init(ScriptName);
+end;
+
+Procedure TAsmScript.AddAsmCommand (Const Command, Options,FileName : String);
+
+begin
+  {$ifdef linux}
+  Add('echo Assembling '+FileName);
+  Add (Command+' '+Options);
+  Add('if [ $? != 0 ]; then DoExitAsm '+FileName+'; fi');
+  {$else}
+  Add('SET THEFILE='+FileName);
+  Add('echo Assembling %THEFILE%');
+  Add(command+' '+Options);
+  Add('if errorlevel 1 goto asmend');
+  {$endif}
+end;
+
+Procedure TasmScript.AddLinkCommand (Const Command, Options, FileName : String);
+
+begin
+  {$ifdef linux}
+  Add('echo Linking '+FileName);
+  Add (Command+' '+Options);
+  Add('if [ $? != 0 ]; then DoExitLink '+FileName+'; fi');
+  {$else}
+  Add('SET THEFILE='+FileName);
+  Add('echo Linking %THEFILE%');
+  Add (Command+' '+Options);
+  Add('if errorlevel 1 goto linkend');
+  {$endif}
+end;
+
+
+ Procedure TAsmScript.AddDeleteCommand (Const FileName : String);
+
+begin
+ {$ifdef linux}
+ Add('rm '+FileName);
+ {$else}
+ Add('Del '+FileName);
+ {$endif}
+end;
+
+
+Procedure TAsmScript.WriteToDisk;
+
+Begin
+{$ifdef linux}
+  AddStart('{ echo "An error occurred while linking $1"; exit 1; }');
+  AddStart('DoExitLink ()');
+  AddStart('{ echo "An error occurred while assembling $1"; exit 1; }');
+  AddStart('DoExitAsm ()');
+  AddStart('#!/bin/bash');
+{$else}
+  AddStart('@echo off');
+  Add('goto end');
+  Add(':asmend');
+  Add('echo An error occured while assembling %THEFILE%');
+  Add('goto end');
+  Add(':linkend');
+  Add('echo An error occured while linking %THEFILE%');
+  Add(':end');
+{$endif}
+  TScript.WriteToDisk;
+end;
+
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:13  root
+  Initial revision
+
+  Revision 1.6  1998/03/10 01:17:28  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.5  1998/02/23 12:53:46  pierre
+    + added some info when running ppas.bat
+      * updated makefile
+
+  Revision 1.4  1998/02/19 00:11:08  peter
+    * fixed -g to work again
+    * fixed some typos with the scriptobject
+
+  Revision 1.3  1998/02/18 14:18:30  michael
+  + added log at end of file (retroactively)
+
+  revision 1.2
+  date: 1998/02/18 13:43:15;  author: michael;  state: Exp;  lines: +75 -20
+  + Implemented an OS independent AsmRes object.
+  ----------------------------
+  revision 1.1
+  date: 1998/02/17 21:44:04;  author: peter;  state: Exp;
+    + Initial implementation
+}

compiler/systems.pas

@@ -0,0 +1,508 @@
+{
+    $Id$
+    Copyright (C) 1995,97 by Florian Klaempfl
+
+    This unit contains informations about the target systems supported
+    (these are not processor specific)
+
+    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 systems;
+
+  interface
+
+    type
+       { target operanting system }
+       ttarget = (target_GO32V1,target_OS2,target_LINUX,
+                  target_WIN32,target_GO32V2,
+                  target_Amiga,target_Atari,target_Mac68k);
+
+       tendian = (endian_little,en_big_endian);
+
+
+       ttargetinfo = record
+          target : ttarget;
+          target_name : string[30];
+          short_name : string[8];
+          unit_env : string[20];
+          system_unit : string[8];
+          exeext,
+          objext,
+          dllext,
+          unitext,
+          libext,
+          asmext,
+          sourceext,
+          pasext  : string[4];
+          newline : string[3];
+          labelprefix : string[2];
+          Cprefix : string[2];
+          use_function_relative_addresses : boolean;
+          endian : tendian;
+       end;
+
+       tsourceinfo = record
+          source:ttarget;
+          source_name:string[30];
+          exeext,
+          scriptext : string[4];
+          endian : tendian;
+       end;
+
+    var
+       source_info : tsourceinfo;
+       target_info : ttargetinfo;
+
+    function set_string_target(const s : string) : boolean;
+
+  implementation
+
+    const
+       target_infos : array[ttarget] of ttargetinfo = (
+          (
+            target : target_GO32V1;
+            target_name : 'GO32 V1 DOS extender';
+            short_name : 'GO32V1';
+            unit_env : 'GO32V1UNITS';
+            system_unit : 'SYSTEM';
+            exeext : '';
+            objext : '.O1';
+            dllext : '.DLL';
+            unitext : '.PP1';
+            libext : '.PPL';
+            asmext : '.S1';
+            sourceext : '.PP';
+            pasext : '.PAS';
+            newline : #13#10;
+            labelprefix : '.L';
+            Cprefix : '_';
+            use_function_relative_addresses : true;
+            endian : endian_little
+          ),
+          (
+            target : target_OS2;
+            target_name : 'OS/2 (32 bit)';
+            short_name : 'OS2';
+            unit_env : 'OS2UNITS';
+            system_unit : 'SYSOS2';
+            exeext : '.exe';
+            objext : '.oo2';
+            dllext : '.dll';
+            unitext : '.ppo';
+            libext : '.ppl';
+            asmext : '.so2';
+            sourceext : '.pas';
+            pasext : '.pp';
+            newline : #13#10;
+            labelprefix : 'L';
+            Cprefix : ''; {???}
+            use_function_relative_addresses : true;
+            endian : endian_little
+          ),
+          (
+            target : target_LINUX;
+            target_name : 'Linux';
+            short_name : 'LINUX';
+            unit_env : 'LINUXUNITS';
+            system_unit : 'syslinux';
+            exeext : '';
+            objext : '.o';
+            dllext : '.so';
+            unitext : '.ppu';
+            libext : '.ppl';
+            asmext : '.s';
+            sourceext : '.pp';
+            pasext : '.pas';
+            newline : #10;
+            labelprefix : '.L';
+            Cprefix : '';
+            use_function_relative_addresses : true;
+            endian : endian_little
+          ),
+          (
+            target : target_WIN32;
+            target_name : 'Win32';
+            short_name : 'WIN32';
+            unit_env : 'WIN32UNITS';
+            system_unit : 'SYSWIN32';
+            exeext : '.exe';
+            objext : '.o';
+            dllext : '.dll';
+            unitext : '.ppw';
+            libext : '.ppl';
+            asmext : '.s';
+            sourceext : '.pp';
+            pasext : '.pas';
+            newline : #13#10;
+            labelprefix : '.L';
+            Cprefix : ''; {???}
+            use_function_relative_addresses : true; {????}
+            endian : endian_little
+          ),
+          (
+            target : target_GO32V2;
+            target_name : 'GO32 V2.0 DOS extender';
+            short_name : 'GO32V2';
+            unit_env : 'GO32V2UNITS';
+            system_unit : 'SYSTEM';
+            exeext : '.EXE';
+            objext : '.O';
+            dllext : '.DLL';
+            unitext : '.PPU';
+            libext : '.PPL';
+            asmext : '.S';
+            sourceext : '.PP';
+            pasext : '.PAS';
+            newline : #13#10;
+            labelprefix : '.L';
+            Cprefix : '_';
+            use_function_relative_addresses : true;
+            endian : endian_little
+          ),
+          (
+            target : target_Amiga;
+            target_name : 'Commodore Amiga';
+            short_name : 'AMIGA';
+            unit_env : '';
+            system_unit : 'sysamiga';  { case sensitive }
+            exeext : '';
+            objext : '.o';
+            dllext : '.library';
+            unitext : '.ppa';
+            libext : '.ppl';
+            asmext : '.asm';
+            sourceext : '.pp';
+            pasext : '.pas';
+            newline : #10;  { ??? }
+            labelprefix : '.L';
+            Cprefix : '';
+            use_function_relative_addresses : true;
+            endian : endian_little
+          ),
+          (
+            target : target_Atari;
+            target_name : 'Atari ST/STE';
+            short_name : 'ATARI';
+            unit_env : '';
+            system_unit : 'SYSATARI';
+            exeext : '.ttp';
+            objext : '.o';
+            dllext : '.dll';
+            unitext : '.PPT';
+            libext : '.PPL';
+            asmext : '.s';
+            sourceext : '.pp';
+            pasext : '.pas';
+            newline : #13#10;
+            labelprefix : '.L';
+            Cprefix : '';
+            use_function_relative_addresses : true;
+            endian : endian_little
+          ),
+          (
+            target : target_Mac68k;
+            target_name : 'Macintosh m68k';
+            short_name : 'MAC OS';
+            unit_env : '';
+            system_unit : 'sysmac';    { case sensitive }
+            exeext : '';
+            objext : '.o';
+            dllext : '.dll';
+            unitext : '.ppm';
+            libext : '.ppl';
+            asmext : '.asm';
+            sourceext : '.pp';
+            pasext : '.pas';
+            newline : #13;   { ??? }
+            labelprefix : '__L';{ only ascii A..Z,a..z or _ allowed as first }
+            Cprefix : '';
+            use_function_relative_addresses : true;
+            endian : endian_little
+          )
+       );
+
+       source_infos : array[ttarget] of tsourceinfo = (
+          (
+            source : target_GO32V1;
+            source_name : 'GO32 V1 DOS extender';
+            exeext : '.EXE';
+            scriptext : '.BAT';
+            endian : endian_little
+          ),
+          (
+            source : target_OS2;
+            source_name : 'OS/2 (32 bit)';
+            exeext : '.EXE';
+            scriptext : '.CMD';
+            endian : endian_little
+          ),
+          (
+            source : target_LINUX;
+            source_name : 'Linux';
+            exeext : '';
+            scriptext : '.sh';
+            endian : endian_little
+          ),
+          (
+            source : target_WIN32;
+            source_name : 'Win32';
+            exeext : '.EXE';
+            scriptext : '.BAT';
+            endian : endian_little
+          ),
+          (
+            source : target_GO32V2;
+            source_name : 'GO32 V2.0 DOS extender';
+            exeext : '.EXE';
+            scriptext : '.BAT';
+            endian : endian_little
+          ),
+          (
+            source : target_Amiga;
+            source_name : 'Commodore Amiga';
+            exeext : '';
+            scriptext : '';
+            endian : en_big_endian
+          ),
+          (
+            source : target_Atari;
+            source_name : 'Atari ST/STE';
+            exeext : '.ttp';
+            scriptext : '';
+            endian : en_big_endian
+          ),
+          (
+            source : target_Mac68k;
+            source_name : 'Macintosh m68k';
+            exeext : '';
+            scriptext : '';
+            endian : en_big_endian
+          )
+       );
+
+    procedure set_target(t : ttarget);
+
+      begin
+         target_info:=target_infos[t];
+      end;
+
+    function set_string_target(const s : string) : boolean;
+
+      var
+         t : ttarget;
+
+      begin
+         set_string_target:=false;
+         for t:=target_GO32V1 to target_mac68k do
+           if target_infos[t].short_name=s then
+             begin
+                set_string_target:=true;
+                set_target(t);
+             end;
+      end;
+
+    procedure default_os(t:ttarget);
+
+      begin
+         set_target(t);
+         source_info:=source_infos[t];
+      end;
+
+begin
+{$ifdef tp}
+  default_os(target_GO32V2);
+{$else}
+  {$ifdef DOS}
+    default_os(target_GO32V1);
+  {$endif}
+  {$ifdef GO32V1}
+    default_os(target_GO32V1);
+  {$endif}
+  {$ifdef GO32V2}
+    default_os(target_GO32V2);
+  {$endif}
+  {$ifdef OS2}
+    default_os(target_OS2);
+  {$endif}
+  {$ifdef LINUX}
+    default_os(target_LINUX);
+  {$endif}
+  {$ifdef WIN32}
+    default_os(target_WIN32);
+  {$endif}
+  {$ifdef AMIGA}
+    default_os(target_AMIGA);
+  {$endif}
+  {$ifdef ATARI}
+    default_os(target_ATARI);
+  {$endif}
+  {$ifdef MACOS}
+    default_os(target_MAC68k);
+  {$endif}
+{$endif}
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.33  1998/03/10 23:48:37  florian
+    * a couple of bug fixes to get the compiler with -OGaxz compiler, sadly
+      enough, it doesn't run
+
+  Revision 1.32  1998/03/10 16:27:46  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.31  1998/03/10 01:17:29  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.30  1998/03/05 22:43:53  florian
+    * some win32 support stuff added
+
+  Revision 1.29  1998/03/02 22:04:36  carl
+    + Added mac line break
+
+  Revision 1.28  1998/03/02 13:38:51  peter
+    + importlib object
+    * doesn't crash on a systemunit anymore
+    * updated makefile and depend
+
+  Revision 1.25  1998/02/28 00:20:34  florian
+    * more changes to get import libs for Win32 working
+
+  Revision 1.24  1998/02/27 22:28:01  florian
+    + win_targ unit
+    + support of sections
+    + new asmlists: sections, exports and resource
+
+  Revision 1.23  1998/02/27 21:24:20  florian
+    * dll support changed (dll name can be also a string contants)
+
+  Revision 1.22  1998/02/23 02:55:08  carl
+    + added correct extension to AMIGA libext
+
+  Revision 1.21  1998/02/22 23:03:39  peter
+    * renamed msource->mainsource and name->unitname
+    * optimized filename handling, filename is not seperate anymore with
+      path+name+ext, this saves stackspace and a lot of fsplit()'s
+    * recompiling of some units in libraries fixed
+    * shared libraries are working again
+    + $LINKLIB <lib> to support automatic linking to libraries
+    + libraries are saved/read from the ppufile, also allows more libraries
+      per ppufile
+
+  Revision 1.20  1998/02/18 14:14:44  michael
+  * removed entries for dos_targ and lin_targ
+
+  Revision 1.19  1998/02/17 21:21:05  peter
+    + Script unit
+    + __EXIT is called again to exit a program
+    - target_info.link/assembler calls
+    * linking works again for dos
+    * optimized a few filehandling functions
+    * fixed stabs generation for procedures
+
+  Revision 1.18  1998/02/14 01:45:35  peter
+    * more fixes
+    - pmode target is removed
+    - search_as_ld is removed, this is done in the link.pas/assemble.pas
+    + findexe() to search for an executable (linker,assembler,binder)
+
+  Revision 1.17  1998/02/13 22:26:45  peter
+    * fixed a few SigSegv's
+    * INIT$$ was not written for linux!
+    * assembling and linking works again for linux and dos
+    + assembler object, only attasmi3 supported yet
+    * restore pp.pas with AddPath etc.
+
+  Revision 1.16  1998/02/13 10:35:50  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.15  1998/02/12 17:19:32  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.14  1998/02/12 11:50:50  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.11  1998/01/26 16:42:01  daniel
+  * Reversed source_ext and pas_ext for OS/2 target. The .pas extension is
+  recognized by the Workplace Shell of OS/2, the .pp is not.
+
+  Revision 1.10  1998/01/26 13:35:33  florian
+    * adapted to work with TP
+
+  Revision 1.9  1998/01/25 18:45:50  peter
+    + Search for as and ld at startup
+    + source_info works the same as target_info
+    + externlink allows only external linking
+
+  Revision 1.8  1998/01/22 08:57:55  peter
+    + added target_info.pasext and target_info.libext
+
+  Revision 1.7  1998/01/09 19:44:09  carl
+    * labels for mac68k target now use the MPW correct syntax
+
+  Revision 1.6  1997/12/12 13:28:42  florian
+  + version 0.99.0
+  * all WASM options changed into MASM
+  + -O2 for Pentium II optimizations
+
+  Revision 1.5  1997/12/09 14:12:21  carl
+  + added planned m68k systems, and fixed some problems in amiga info.
+
+  Revision 1.4  1997/12/08 11:53:49  pierre
+      reverted to old version of systems.pas,
+      Daniel's version is not compilable due to the bug (corrected) of
+      mil value for a procvar const !!
+
+  Revision 1.1.1.1  1997/11/27 08:33:02  michael
+  FPC Compiler CVS start
+
+  Pre-CVS log:
+
+    CEC    Carl-Eric Codere
+    FK     Florian Klaempfl
+    +      feature added
+    -      removed
+    *      bug fixed or changed
+
+  History:
+      15th october 1996:
+         + ttargetinfo.newline added (FK)
+      19th september 1997:
+         * the suffix of GO32V1 units is now PP1 (FK)
+       8th october 1997:
+         + target amiga added for tests, unit should divided
+           into sysi386 and sysm68k (FK)
+}

compiler/tgen68k.pas

@@ -0,0 +1,662 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl, Carl Eric Codere
+
+    This unit handles the temporary variables stuff for m68k
+
+    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 tgen68k;
+
+  interface
+
+    uses
+       cobjects,globals,tree,hcodegen,verbose,files,aasm
+{$ifdef m68k}
+       ,m68k
+{$endif}
+       ;
+
+    type
+       tregisterset = set of tregister;
+       tpushed = array[R_D0..R_A6] of boolean;
+
+    const
+       { D2 to D5 usable as scratch registers }
+       usablereg32 : byte = 4;
+       { A2 to A4 usable as address registers }
+       usableaddress: byte = 3;
+       { FP2 to FP7 usable as FPU registers   }
+       usablefloatreg : byte = 6;
+
+    function getregister32 : tregister;
+    procedure ungetregister32(r : tregister);
+    { return a free 32-bit address register }
+    function getaddressreg: tregister;
+
+    procedure ungetregister(r : tregister);
+
+    procedure cleartempgen;
+
+    { generates temporary variables }
+    procedure resettempgen;
+    procedure setfirsttemp(l : longint);
+    function gettempsize : longint;
+    function gettempofsize(size : longint) : longint;
+    procedure gettempofsizereference(l : longint;var ref : treference);
+    function istemp(const ref : treference) : boolean;
+    procedure ungetiftemp(const ref : treference);
+    function getfloatreg: tregister;
+    { returns a free floating point register }
+    { used in real, fpu mode, otherwise we   }
+    { must use standard register allocation  }
+
+    procedure del_reference(const ref : treference);
+    procedure del_locref(const location : tlocation);
+
+
+    { pushs and restores registers }
+    procedure pushusedregisters(var pushed : tpushed;b : word);
+    procedure popusedregisters(const pushed : tpushed);
+
+    var
+       unused,usableregs : tregisterset;
+       c_usableregs : longint;
+
+       usedinproc : word;
+
+       { count, how much a register must be pushed if it is used as register }
+       { variable                                                            }
+       reg_pushes : array[R_D0..R_A6] of longint;
+       is_reg_var : array[R_D0..R_A6] of boolean;
+
+  implementation
+
+    procedure pushusedregisters(var pushed : tpushed;b : word);
+
+      var
+         r : tregister;
+
+      begin
+         { the following registers can be pushed }
+         { D0, D1, D2, D3, D4, D5, D6, D7, A0    }
+         { A1, A2, A3, A4                        }
+         for r:=R_D2 to R_A4 do
+           begin
+              pushed[r]:=false;
+              { if the register is used by the calling subroutine    }
+              if ((b and ($800 shr word(r)))<>0) then
+                begin
+                   { and is present in use }
+                   if not(r in unused) then
+                     begin
+                        { then save it }
+                        { then save it on the stack }
+                        exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,r,R_SPPUSH)));
+                        { here was a big problem  !!!!!}
+                        { you cannot do that for a register that is
+                        globally assigned to a var
+                        this also means that you must push it much more
+                        often, but there must be a better way
+                        maybe by putting the value back to the stack !! }
+                        if not(is_reg_var[r]) then
+                          unused:=unused+[r];
+                        pushed[r]:=true;
+                     end;
+                end;
+           end;
+      end;
+
+    procedure popusedregisters(const pushed : tpushed);
+
+      var
+         r : tregister;
+
+      begin
+         for r:=R_A4 downto R_D2 do
+           if pushed[r] then
+             begin
+                exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_SPPULL,r)));
+                unused:=unused-[r];
+             end;
+      end;
+
+    procedure ungetregister(r : tregister);
+
+      begin
+           ungetregister32(r)
+      end;
+
+
+    procedure del_reference(const ref : treference);
+
+      begin
+         if ref.isintvalue then
+           exit;
+         ungetregister(ref.base);
+         ungetregister32(ref.index);
+      end;
+
+    procedure del_locref(const location : tlocation);
+
+      begin
+         if (location.loc<>loc_mem) and (location.loc<>loc_reference) then
+           exit;
+         if location.reference.isintvalue then
+           exit;
+         ungetregister(location.reference.base);
+         ungetregister32(location.reference.index);
+      end;
+
+    procedure ungetregister32(r : tregister);
+
+      begin
+         if r in [R_D2,R_D3,R_D4,R_D5,R_D7] then
+          begin
+             unused:=unused+[r];
+             inc(usablereg32);
+          end
+         else
+         if r in [R_FP2,R_FP3,R_FP4,R_FP5,R_FP6,R_FP7] then
+         begin
+              unused:=unused+[r];
+              inc(usablefloatreg);
+         end
+         else
+         if r in [R_A2,R_A3,R_A4,R_A6,R_SP] then
+           begin
+              unused:=unused+[r];
+              inc(usableaddress);
+{$ifdef EXTDEBUG}
+           end
+         else
+         begin
+           if not (r in [R_NO]) then
+           begin
+            Comment(V_Debug,'ungetregister32() deallocation of reserved register.');
+         end;
+         end;
+{$ELSE}
+           end;
+{$ENDIF}
+      end;
+
+
+    function getfloatreg: tregister;
+    { returns a free floating point register }
+    { used in real, fpu mode, otherwise we   }
+    { must use standard register allocation  }
+    var
+     i:tregister;
+    begin
+      dec(usablefloatreg);
+      if usablefloatreg = 0 then
+       Message(cg_f_internal_error_in_getfloatreg);
+      for i:=R_FP2 to R_FP7 do
+      begin
+         if i in unused then
+         begin
+           unused := unused-[i];
+           getfloatreg := i;
+           exit;
+         end;
+      end;
+      { if we are here, then there was an allocation failure }
+      Message(cg_f_internal_error_in_getfloatreg);
+    end;
+
+
+    function getaddressreg: tregister;
+
+     begin
+         dec(usableaddress);
+         if R_A2 in unused then
+           begin
+              unused:=unused-[R_A2];
+              usedinproc:=usedinproc or ($800 shr word(R_A2));
+              getaddressreg:=R_A2;
+           end
+         else
+         if R_A3 in unused then
+           begin
+              unused:=unused-[R_A3];
+              usedinproc:=usedinproc or ($800 shr word(R_A3));
+              getaddressreg:=R_A3;
+           end
+         else
+         if R_A4 in unused then
+           begin
+              unused:=unused-[R_A4];
+              usedinproc:=usedinproc or ($800 shr word(R_A4));
+              getaddressreg:=R_A4;
+           end
+         else
+         begin
+           internalerror(10);
+         end;
+
+     end;
+
+    function getregister32 : tregister;
+      begin
+         dec(usablereg32);
+         if R_D2 in unused then
+           begin
+              unused:=unused-[R_D2];
+              usedinproc:=usedinproc or ($800 shr word(R_D2));
+              getregister32:=R_D2;
+           end
+         else if R_D3 in unused then
+           begin
+              unused:=unused-[R_D3];
+              usedinproc:=usedinproc or ($800 shr word(R_D3));
+              getregister32:=R_D3;
+           end
+         else if R_D4 in unused then
+           begin
+              unused:=unused-[R_D4];
+              usedinproc:=usedinproc or ($800 shr word(R_D4));
+              getregister32:=R_D4;
+           end
+         else if R_D5 in unused then
+           begin
+             unused:=unused-[R_D5];
+             usedinproc:=usedinproc or ($800 shr word(R_D5));
+             getregister32:=R_D5;
+           end
+         else if R_D7 in unused then
+           begin
+             unused:=unused-[R_D7];
+             usedinproc:=usedinproc or ($800 shr word(R_D7));
+             getregister32:=R_D7;
+           end
+         else
+         begin
+          internalerror(10);
+         end;
+      end;
+
+    procedure cleartempgen;
+
+      begin
+         unused:=usableregs;
+         usablereg32:=c_usableregs;
+      end;
+
+    type
+       pfreerecord = ^tfreerecord;
+
+       tfreerecord = record
+          next : pfreerecord;
+          pos : longint;
+          size : longint;
+{$ifdef EXTDEBUG}
+          line : longint;
+{$endif}
+       end;
+
+    var
+       tmpfreelist : pfreerecord;
+       templist : pfreerecord;
+       lastoccupied : longint;
+       firsttemp, maxtemp : longint;
+
+    procedure resettempgen;
+
+      var
+         hp : pfreerecord;
+
+      begin
+         while assigned(tmpfreelist) do
+           begin
+              hp:=tmpfreelist;
+              tmpfreelist:=hp^.next;
+              dispose(hp);
+           end;
+         while assigned(templist) do
+           begin
+{$ifdef EXTDEBUG}
+              Comment(V_Warning,'temporary assignment of size '
+                       +tostr(templist^.size)+' from '+tostr(templist^.line)+
+                       +' at pos '+tostr(templist^.pos)+
+                       ' not freed at the end of the procedure');
+{$endif}
+              hp:=templist;
+              templist:=hp^.next;
+{$ifndef EXTDEBUG}
+              dispose(hp);
+{$endif not EXTDEBUG}
+           end;
+         templist:=nil;
+         tmpfreelist:=nil;
+         firsttemp:=0;
+         maxtemp:=0;
+         lastoccupied:=0;
+      end;
+
+    procedure setfirsttemp(l : longint);
+
+      begin
+         if odd(l) then
+          l:=l+1;
+         firsttemp:=l;
+         maxtemp := l;
+         lastoccupied:=l;
+      end;
+
+    function gettempofsize(size : longint) : longint;
+
+      var
+         last,hp : pfreerecord;
+
+      begin
+         { this code comes from the heap management of FPC ... }
+         if (size mod 4)<>0 then
+           size:=size+(4-(size mod 4));
+           if assigned(tmpfreelist) then
+             begin
+                last:=nil;
+                hp:=tmpfreelist;
+                while assigned(hp) do
+                  begin
+                     { first fit }
+                     if hp^.size>=size then
+                       begin
+                          gettempofsize:=hp^.pos;
+                          if hp^.pos-size < maxtemp then
+                            maxtemp := hp^.size-size;
+                          { the whole block is needed ? }
+                          if hp^.size>size then
+                            begin
+                               hp^.size:=hp^.size-size;
+                               hp^.pos:=hp^.pos-size;
+                            end
+                          else
+                            begin
+                               if assigned(last) then
+                                 last^.next:=hp^.next
+                               else
+                                 tmpfreelist:=nil;
+                               dispose(hp);
+                            end;
+                          exit;
+                       end;
+                     last:=hp;
+                     hp:=hp^.next;
+                  end;
+             end;
+          { nothing free is big enough : expand temp }
+          gettempofsize:=lastoccupied-size;
+          lastoccupied:=lastoccupied-size;
+          if lastoccupied < maxtemp then
+            maxtemp := lastoccupied;
+      end;
+
+    function gettempsize : longint;
+
+      begin
+         { we only push words and we want to stay on }
+         { even stack addresses                      }
+         { maxtemp is negative                       }
+         if (maxtemp mod 2)<>0 then
+           dec(maxtemp);
+         gettempsize:=-maxtemp;
+      end;
+
+    procedure gettempofsizereference(l : longint;var ref : treference);
+
+      var
+         tl : pfreerecord;
+
+      begin
+         { do a reset, because the reference isn't used }
+         reset_reference(ref);
+         ref.offset:=gettempofsize(l);
+         ref.base:=procinfo.framepointer;
+         new(tl);
+         tl^.pos:=ref.offset;
+         tl^.size:=l;
+         tl^.next:=templist;
+         templist:=tl;
+{$ifdef EXTDEBUG}
+         tl^.line:=current_module^.current_inputfile^.line_no;
+{$endif}
+      end;
+
+    function istemp(const ref : treference) : boolean;
+
+      begin
+         istemp:=((ref.base=procinfo.framepointer) and
+           (ref.offset<firsttemp));
+      end;
+
+    procedure ungettemp(pos : longint;size : longint);
+
+      var
+         hp,newhp : pfreerecord;
+
+      begin
+         if (size mod 4)<>0 then
+           size:=size+(4-(size mod 4));
+         if size = 0 then
+           exit;
+         if pos<=lastoccupied then
+           if pos=lastoccupied then
+             begin
+                lastoccupied:=pos+size;
+                hp:=tmpfreelist;
+                newhp:=nil;
+                while assigned(hp) do
+                  begin
+                     { conneting a free block }
+                     if hp^.pos=lastoccupied then
+                        begin
+                           if assigned(newhp) then newhp^.next:=nil
+                             else tmpfreelist:=nil;
+                           lastoccupied:=lastoccupied+hp^.size;
+                           dispose(hp);
+                           break;
+                        end;
+                     newhp:=hp;
+                     hp:=hp^.next;
+                  end;
+             end
+           else
+             begin
+{$ifdef EXTDEBUG}
+              Comment(V_Warning,'temp managment problem : ungettemp() pos < lastoccupied !');
+{$endif}
+             end
+         else
+           begin
+              new(newhp);
+              { size can be allways set }
+              newhp^.size:=size;
+              newhp^.pos := pos;
+              { if there is no free list }
+              if not assigned(tmpfreelist) then
+                begin
+                   { then generate one }
+                   tmpfreelist:=newhp;
+                   newhp^.next:=nil;
+                   exit;
+                end;
+              { search the position to insert }
+              hp:=tmpfreelist;
+              while assigned(hp) do
+                begin
+                   { conneting two blocks ? }
+                   if hp^.pos+hp^.size=pos then
+                      begin
+                         inc(hp^.size,size);
+                         dispose(newhp);
+                         break;
+                      end
+                   { if the end is reached, then concat }
+                   else if hp^.next=nil then
+                     begin
+                        hp^.next:=newhp;
+                        newhp^.next:=nil;
+                        break;
+                     end
+                   { falls der n„chste Zeiger gr”áer ist, dann }
+                   { Einh„ngen                                 }
+                   else if hp^.next^.pos<=pos+size then
+                     begin
+                        { concat two blocks ? }
+                        if pos+size=hp^.next^.pos then
+                          begin
+                             newhp^.next:=hp^.next^.next;
+                             inc(newhp^.size,hp^.next^.size);
+                             dispose(hp^.next);
+                             hp^.next:=newhp;
+                          end
+                        else
+                          begin
+                             newhp^.next:=hp^.next;
+                             hp^.next:=newhp;
+                          end;
+                        break;
+                     end;
+                   hp:=hp^.next;
+                end;
+           end;
+      end;
+
+    procedure ungetiftemp(const ref : treference);
+
+      var
+         tl,prev : pfreerecord;
+
+      begin
+         if istemp(ref) then
+           begin
+              prev:=nil;
+              tl:=templist;
+              while assigned(tl) do
+                begin
+                   if ref.offset=tl^.pos then
+                     begin
+                        ungettemp(ref.offset,tl^.size);
+                        if assigned(prev) then
+                          prev^.next:=tl^.next
+                        else
+                          templist:=tl^.next;
+                        dispose(tl);
+                        exit;
+                     end
+                   else
+                     begin
+                        prev:=tl;
+                        tl:=tl^.next;
+                     end;
+                end;
+{$ifdef EXTDEBUG}
+              Comment(V_Warning,'Internal: temp managment problem : '+
+                'temp not found for release at offset '+tostr(ref.offset));
+{$endIf}
+           end;
+      end;
+
+begin
+   { contains both information on Address registers and data registers }
+   { even if they are allocated separately.                            }
+   usableregs:=[R_D0,R_D1,R_D2,R_D3,R_D4,R_D5,R_D6,R_D7,R_A0,R_A1,R_A2,R_A3,R_A4,
+               R_FP0,R_FP1,R_FP2,R_FP3,R_FP4,R_FP5,R_FP6,R_FP7];
+   c_usableregs:=4;
+   tmpfreelist:=nil;
+   templist:=nil;
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.12  1998/03/22 12:45:38  florian
+    * changes of Carl-Eric to m68k target commit:
+      - wrong nodes because of the new string cg in intel, I had to create
+        this under m68k also ... had to work it out to fix potential alignment
+        problems --> this removes the crash of the m68k compiler.
+      - added absolute addressing in m68k assembler (required for Amiga startup)
+      - fixed alignment problems (because of byte return values, alignment
+        would not be always valid) -- is this ok if i change the offset if odd in
+        setfirsttemp ?? -- it seems ok...
+
+  Revision 1.11  1998/03/10 04:21:15  carl
+    * fixed extdebug problems
+
+  Revision 1.10  1998/03/10 01:17:30  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.9  1998/03/06 00:53:00  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.8  1998/03/02 01:49:35  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.7  1998/02/13 10:35:51  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.6  1998/01/11 03:40:16  carl
+    + added fpu register allocation
+
+  Revision 1.3  1997/12/09 14:13:07  carl
+  * bugfix of free register list.
+
+  Revision 1.2  1997/11/28 18:14:49  pierre
+   working version with several bug fixes
+
+  Revision 1.1.1.1  1997/11/27 08:33:03  michael
+  FPC Compiler CVS start
+
+  Pre-CVS log:
+
+  + feature added
+  - removed
+  * bug fixed or changed
+
+  History (started with version 0.9.0):
+       7th december 1996:
+         * some code from Pierre Muller inserted
+           makes the use of the stack more efficient
+   5th september 1997:
+        + Converted for Motorola MC68000 output (C. E. Codere)
+   24nd september 1997:
+        + Reserved register list modified. (CEC)
+   26 september 1997:
+        + Converted to work with v093 (CEC)
+        * Knowing that base is in address register, modified routines
+          accordingly. (CEC)
+   27 september 1997:
+      + pushusedregisters now pushes only non-scratch registers.
+    2nd october 1997:
+      + added strict error checking when extdebug defined.
+   23 october 1997:
+      - it seems that sp, and the base pointer can be freed in ungetregister,
+        removed warning accordingly. (CEC).
+      * bugfix of address register in usableregs set. (They were not defined...) (CEC).
+      * other stupid bug! When I changed the register conventions, I forgot to change
+        getaddressreg to reflect those changes!! (CEC).
+
+}

compiler/tgeni386.pas

@@ -0,0 +1,652 @@
+{
+    $Id$
+    Copyright (C) 1993-98 by Florian Klaempfl
+
+    This unit handles the temporary variables stuff for i386
+
+    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 tgeni386;
+
+  interface
+
+    uses
+       cobjects,globals,tree,hcodegen,verbose,files,aasm
+{$ifdef i386}
+       ,i386
+{$endif}
+       ;
+
+    type
+       tregisterset = set of tregister;
+
+       tpushed = array[R_EAX..R_MM6] of boolean;
+
+    const
+       usablereg32 : byte = 4;
+{$ifdef SUPPORT_MMX}
+       usableregmmx : byte = 8;
+{$endif SUPPORT_MMX}
+
+    function getregister32 : tregister;
+    procedure ungetregister32(r : tregister);
+{$ifdef SUPPORT_MMX}
+    function getregistermmx : tregister;
+    procedure ungetregistermmx(r : tregister);
+{$endif SUPPORT_MMX}
+
+    procedure ungetregister(r : tregister);
+
+    procedure cleartempgen;
+
+    { generates temporary variables }
+    procedure resettempgen;
+    procedure setfirsttemp(l : longint);
+    function gettempsize : longint;
+    function gettempofsize(size : longint) : longint;
+    procedure gettempofsizereference(l : longint;var ref : treference);
+    function istemp(const ref : treference) : boolean;
+    procedure ungetiftemp(const ref : treference);
+
+    procedure del_reference(const ref : treference);
+    procedure del_locref(const location : tlocation);
+
+
+    { pushs and restores registers }
+    procedure pushusedregisters(var pushed : tpushed;b : byte);
+    procedure popusedregisters(const pushed : tpushed);
+
+    var
+       unused,usableregs : tregisterset;
+       c_usableregs : longint;
+
+       { uses only 1 byte while a set uses in FPC 32 bytes }
+       usedinproc : byte;
+
+       { count, how much a register must be pushed if it is used as register }
+       { variable                                                            }
+{$ifdef SUPPORT_MMX}
+       reg_pushes : array[R_EAX..R_MM6] of longint;
+       is_reg_var : array[R_EAX..R_MM6] of boolean;
+{$else SUPPORT_MMX}
+       reg_pushes : array[R_EAX..R_EDI] of longint;
+       is_reg_var : array[R_EAX..R_EDI] of boolean;
+{$endif SUPPORT_MMX}
+  implementation
+
+    procedure pushusedregisters(var pushed : tpushed;b : byte);
+
+      var
+         r : tregister;
+         hr : preference;
+
+      begin
+         usedinproc:=usedinproc or b;
+         for r:=R_EAX to R_EBX do
+           begin
+              pushed[r]:=false;
+              { if the register is used by the calling subroutine    }
+              if ((b and ($80 shr byte(r)))<>0) then
+                begin
+                   { and is present in use }
+                   if not(r in unused) then
+                     begin
+                        { then save it }
+                        exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,r)));
+                        { here was a big problem  !!!!!}
+                        { you cannot do that for a register that is
+                        globally assigned to a var
+                        this also means that you must push it much more
+                        often, but there must be a better way
+                        maybe by putting the value back to the stack !! }
+                        if not(is_reg_var[r]) then
+                          unused:=unused+[r];
+                        pushed[r]:=true;
+                     end;
+                end;
+           end;
+{$ifdef SUPPORT_MMX}
+         for r:=R_MM0 to R_MM6 do
+           begin
+              pushed[r]:=false;
+              { if the mmx register is in use, save it }
+              if not(r in unused) then
+                begin
+                   exprasmlist^.concat(new(pai386,op_const_reg(
+                     A_SUB,S_L,8,R_ESP)));
+                   new(hr);
+                   reset_reference(hr^);
+                   hr^.base:=R_ESP;
+                   exprasmlist^.concat(new(pai386,op_reg_ref(
+                     A_MOVQ,S_NO,r,hr)));
+                   if not(is_reg_var[r]) then
+                     unused:=unused+[r];
+                   pushed[r]:=true;
+                end;
+           end;
+{$endif SUPPORT_MMX}
+      end;
+
+    procedure popusedregisters(const pushed : tpushed);
+
+      var
+         r : tregister;
+         hr : preference;
+
+      begin
+         { restore in reverse order: }
+{$ifdef SUPPORT_MMX}
+         for r:=R_MM6 downto R_MM0 do
+           begin
+              if pushed[r] then
+                begin
+                   new(hr);
+                   reset_reference(hr^);
+                   hr^.base:=R_ESP;
+                   exprasmlist^.concat(new(pai386,op_ref_reg(
+                     A_MOVQ,S_NO,hr,r)));
+                   exprasmlist^.concat(new(pai386,op_const_reg(
+                     A_ADD,S_L,8,R_ESP)));
+                   unused:=unused-[r];
+                end;
+           end;
+{$endif SUPPORT_MMX}
+         for r:=R_EBX downto R_EAX do
+           if pushed[r] then
+             begin
+                exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,r)));
+                unused:=unused-[r];
+             end;
+      end;
+
+    procedure ungetregister(r : tregister);
+
+      begin
+         if r in [R_EAX,R_ECX,R_EDX,R_EBX,R_ESP,R_EBP,R_ESI,R_EDI] then
+           ungetregister32(r)
+         else if r in [R_AX,R_CX,R_DX,R_BX,R_SP,R_BP,R_SI,R_DI] then
+           ungetregister32(reg16toreg32(r))
+         else if r in [R_AL,R_BL,R_CL,R_DL] then
+           ungetregister32(reg8toreg32(r))
+{$ifdef SUPPORT_MMX}
+         else if r in [R_MM0..R_MM6] then
+           ungetregistermmx(r)
+{$endif SUPPORT_MMX}
+         else internalerror(18);
+      end;
+
+    procedure ungetregister32(r : tregister);
+
+      begin
+         if cs_maxoptimieren in aktswitches then
+           begin
+              { takes much time }
+              if not(r in usableregs) then
+                exit;
+              unused:=unused+[r];
+              inc(usablereg32);
+           end
+         else
+           begin
+              if not(r in [R_EAX,R_EBX,R_ECX,R_EDX]) then
+                exit;
+              unused:=unused+[r];
+              inc(usablereg32);
+           end;
+      end;
+
+{$ifdef SUPPORT_MMX}
+    function getregistermmx : tregister;
+
+      var
+         r : tregister;
+
+      begin
+         dec(usableregmmx);
+         for r:=R_MM0 to R_MM6 do
+           if r in unused then
+             begin
+                unused:=unused-[r];
+                usedinproc:=usedinproc or ($80 shr byte(R_EAX));
+                getregistermmx:=r;
+                exit;
+             end;
+         internalerror(10);
+      end;
+
+    procedure ungetregistermmx(r : tregister);
+
+      begin
+         if cs_maxoptimieren in aktswitches then
+           begin
+              { takes much time }
+              if not(r in usableregs) then
+                exit;
+              unused:=unused+[r];
+              inc(usableregmmx);
+           end
+         else
+           begin
+              unused:=unused+[r];
+              inc(usableregmmx);
+           end;
+      end;
+{$endif SUPPORT_MMX}
+
+    procedure del_reference(const ref : treference);
+
+      begin
+         if ref.isintvalue then
+           exit;
+         ungetregister32(ref.base);
+         ungetregister32(ref.index);
+         { ref.segment:=R_DEFAULT_SEG; }
+      end;
+
+    procedure del_locref(const location : tlocation);
+
+      begin
+         if (location.loc<>loc_mem) and (location.loc<>loc_reference) then
+           exit;
+         if location.reference.isintvalue then
+           exit;
+         ungetregister32(location.reference.base);
+         ungetregister32(location.reference.index);
+         { ref.segment:=R_DEFAULT_SEG; }
+      end;
+
+    function getregister32 : tregister;
+
+      begin
+         dec(usablereg32);
+         if R_EAX in unused then
+           begin
+              unused:=unused-[R_EAX];
+              usedinproc:=usedinproc or ($80 shr byte(R_EAX));
+              getregister32:=R_EAX;
+           end
+         else if R_EDX in unused then
+           begin
+              unused:=unused-[R_EDX];
+              usedinproc:=usedinproc or ($80 shr byte(R_EDX));
+              getregister32:=R_EDX;
+           end
+         else if R_EBX in unused then
+           begin
+              unused:=unused-[R_EBX];
+              usedinproc:=usedinproc or ($80 shr byte(R_EBX));
+              getregister32:=R_EBX;
+           end
+         else if R_ECX in unused then
+           begin
+              unused:=unused-[R_ECX];
+              usedinproc:=usedinproc or ($80 shr byte(R_ECX));
+              getregister32:=R_ECX;
+           end
+         else internalerror(10);
+      end;
+
+    procedure cleartempgen;
+
+      begin
+         unused:=usableregs;
+         usablereg32:=c_usableregs;
+      end;
+
+    type
+       pfreerecord = ^tfreerecord;
+
+       tfreerecord = record
+          next : pfreerecord;
+          pos : longint;
+          size : longint;
+{$ifdef EXTDEBUG}
+          line : longint;
+{$endif}
+       end;
+
+    var
+       tmpfreelist : pfreerecord;
+       templist : pfreerecord;
+       lastoccupied : longint;
+       firsttemp, maxtemp : longint;
+
+    procedure resettempgen;
+
+      var
+         hp : pfreerecord;
+
+      begin
+         while assigned(tmpfreelist) do
+           begin
+              hp:=tmpfreelist;
+              tmpfreelist:=hp^.next;
+              dispose(hp);
+           end;
+         while assigned(templist) do
+           begin
+{$ifdef EXTDEBUG}
+              Comment(V_Warning,'temporary assignment of size '
+                       +tostr(templist^.size)+' from '+tostr(templist^.line)+
+                       +' at pos '+tostr(templist^.pos)+
+                       ' not freed at the end of the procedure');
+{$endif}
+              hp:=templist;
+              templist:=hp^.next;
+{$ifndef EXTDEBUG}
+              dispose(hp);
+{$endif not EXTDEBUG}
+           end;
+         templist:=nil;
+         tmpfreelist:=nil;
+         firsttemp:=0;
+         maxtemp:=0;
+         lastoccupied:=0;
+      end;
+
+    procedure setfirsttemp(l : longint);
+
+      begin
+         { generates problems
+         if (l mod 4 <> 0) then dec(l,l mod 4);}
+         firsttemp:=l;
+         maxtemp := l;
+         lastoccupied:=l;
+      end;
+
+    function gettempofsize(size : longint) : longint;
+
+      var
+         last,hp : pfreerecord;
+
+      begin
+         { this code comes from the heap management of FPC ... }
+         if (size mod 4)<>0 then
+           size:=size+(4-(size mod 4));
+           if assigned(tmpfreelist) then
+             begin
+                last:=nil;
+                hp:=tmpfreelist;
+                while assigned(hp) do
+                  begin
+                     { first fit }
+                     if hp^.size>=size then
+                       begin
+                          gettempofsize:=hp^.pos;
+                          if hp^.pos-size < maxtemp then
+                            maxtemp := hp^.size-size;
+                          { the whole block is needed ? }
+                          if hp^.size>size then
+                            begin
+                               hp^.size:=hp^.size-size;
+                               hp^.pos:=hp^.pos-size;
+                            end
+                          else
+                            begin
+                               if assigned(last) then
+                                 last^.next:=hp^.next
+                               else
+                                 tmpfreelist:=nil;
+                               dispose(hp);
+                            end;
+                          exit;
+                       end;
+                     last:=hp;
+                     hp:=hp^.next;
+                  end;
+             end;
+          { nothing free is big enough : expand temp }
+          gettempofsize:=lastoccupied-size;
+          lastoccupied:=lastoccupied-size;
+          if lastoccupied < maxtemp then
+            maxtemp := lastoccupied;
+      end;
+
+    function gettempsize : longint;
+
+      begin
+         { align local data to dwords }
+         if (maxtemp mod 4)<>0 then
+           dec(maxtemp,4+(maxtemp mod 4));
+         gettempsize:=-maxtemp;
+      end;
+
+    procedure gettempofsizereference(l : longint;var ref : treference);
+
+      var
+         tl : pfreerecord;
+
+      begin
+         { do a reset, because the reference isn't used }
+         reset_reference(ref);
+         ref.offset:=gettempofsize(l);
+         ref.base:=procinfo.framepointer;
+         new(tl);
+         tl^.pos:=ref.offset;
+         tl^.size:=l;
+         tl^.next:=templist;
+         templist:=tl;
+{$ifdef EXTDEBUG}
+         tl^.line:=current_module^.current_inputfile^.line_no;
+{$endif}
+      end;
+
+    function istemp(const ref : treference) : boolean;
+
+      begin
+         istemp:=((ref.base=procinfo.framepointer) and
+           (ref.offset<firsttemp));
+      end;
+
+    procedure ungettemp(pos : longint;size : longint);
+
+      var
+         hp,newhp : pfreerecord;
+
+      begin
+         if (size mod 4)<>0 then
+           size:=size+(4-(size mod 4));
+         if size = 0 then
+           exit;
+         if pos<=lastoccupied then
+           if pos=lastoccupied then
+             begin
+                lastoccupied:=pos+size;
+                hp:=tmpfreelist;
+                newhp:=nil;
+                while assigned(hp) do
+                  begin
+                     { conneting a free block }
+                     if hp^.pos=lastoccupied then
+                        begin
+                           if assigned(newhp) then newhp^.next:=nil
+                             else tmpfreelist:=nil;
+                           lastoccupied:=lastoccupied+hp^.size;
+                           dispose(hp);
+                           break;
+                        end;
+                     newhp:=hp;
+                     hp:=hp^.next;
+                  end;
+             end
+           else
+             begin
+{$ifdef EXTDEBUG}
+              Comment(V_Warning,'temp managment problem : ungettemp() pos < lastoccupied !');
+{$endif}
+             end
+         else
+           begin
+              new(newhp);
+              { size can be allways set }
+              newhp^.size:=size;
+              newhp^.pos := pos;
+              { if there is no free list }
+              if not assigned(tmpfreelist) then
+                begin
+                   { then generate one }
+                   tmpfreelist:=newhp;
+                   newhp^.next:=nil;
+                   exit;
+                end;
+              { search the position to insert }
+              hp:=tmpfreelist;
+              while assigned(hp) do
+                begin
+                   { conneting two blocks ? }
+                   if hp^.pos+hp^.size=pos then
+                      begin
+                         inc(hp^.size,size);
+                         dispose(newhp);
+                         break;
+                      end
+                   { if the end is reached, then concat }
+                   else if hp^.next=nil then
+                     begin
+                        hp^.next:=newhp;
+                        newhp^.next:=nil;
+                        break;
+                     end
+                   { falls der n„chste Zeiger gr”áer ist, dann }
+                   { Einh„ngen                                 }
+                   else if hp^.next^.pos<=pos+size then
+                     begin
+                        { concat two blocks ? }
+                        if pos+size=hp^.next^.pos then
+                          begin
+                             newhp^.next:=hp^.next^.next;
+                             inc(newhp^.size,hp^.next^.size);
+                             dispose(hp^.next);
+                             hp^.next:=newhp;
+                          end
+                        else
+                          begin
+                             newhp^.next:=hp^.next;
+                             hp^.next:=newhp;
+                          end;
+                        break;
+                     end;
+                   hp:=hp^.next;
+                end;
+           end;
+      end;
+
+    procedure ungetiftemp(const ref : treference);
+
+      var
+         tl,prev : pfreerecord;
+
+      begin
+         if istemp(ref) then
+           begin
+              prev:=nil;
+              tl:=templist;
+              while assigned(tl) do
+                begin
+                   if ref.offset=tl^.pos then
+                     begin
+                        ungettemp(ref.offset,tl^.size);
+                        if assigned(prev) then
+                          prev^.next:=tl^.next
+                        else
+                          templist:=tl^.next;
+                        dispose(tl);
+                        exit;
+                     end
+                   else
+                     begin
+                        prev:=tl;
+                        tl:=tl^.next;
+                     end;
+                end;
+{$ifdef EXTDEBUG}
+              Comment(V_Warning,'Internal: temp managment problem : '+
+                'temp not found for release at offset '+tostr(ref.offset));
+{$endIf}
+           end;
+      end;
+
+begin
+   usableregs:=[R_EAX,R_EBX,R_ECX,R_EDX];
+{$ifdef SUPPORT_MMX}
+   usableregs:=usableregs+[R_MM0..R_MM6];
+{$endif SUPPORT_MMX}
+   c_usableregs:=4;
+   tmpfreelist:=nil;
+   templist:=nil;
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.9  2036/02/07 09:26:57  florian
+    * more fixes to get -Ox work
+
+  Revision 1.8  1998/03/10 01:17:30  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.7  1998/03/02 01:49:36  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:52  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.5  1998/02/12 17:19:32  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.4  1998/02/12 11:50:50  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.3  1998/02/04 22:02:46  florian
+    + complete handling of MMX registers
+
+  Revision 1.2  1998/01/07 00:13:44  michael
+  Restored released version (plus fixes) as current
+
+  Revision 1.1.1.1  1997/11/27 08:33:03  michael
+  FPC Compiler CVS start
+
+  Pre-CVS log:
+
+  FK   Florian Klaempfl
+  PM   Pierre Muller
+  +    feature added
+  -    removed
+  *    bug fixed or changed
+
+  History (started with version 0.9.0):
+       7th december 1996:
+         * some code from Pierre Muller inserted
+           makes the use of the stack more efficient
+       20th november 1997:
+         * tempsize is multiple of 4 for alignment (PM), buggy commented (PM)
+}
+

compiler/todo.txt

@@ -0,0 +1,54 @@
+This list contains tasks which should be done til version 1.0.
+Don't hesitate to insert jobs :)
+Don't insert bugs there, for this purpose is the bugs directory.
+
+Please indent task which are done 8 spaces and add the
+compiler version and your short cut.
+
+* OPOM (Object Pascal Object Modell)
+  - virtual constructors
+  * properties
+    - save the def and not the sym which
+      does read/write access
+    - indexed properties
+    - default properties
+    - stored qualifier
+    - read/write from/to unit file
+  - call of destructor helper routine
+  - message qualifier
+  - correct handling of constructor result type
+  - rtti
+  - dynamic methods
+  - correct handling of access specifiers
+* MMX support by the compiler
+          - unary minus .......................................... 0.99.1 (FK)
+          - proper handling of fixed type ........................ 0.99.1 (FK)
+  - array access
+          - binary operators ..................................... 0.99.1 (FK)
+          - mul operator ......................................... 0.99.1 (FK)
+  * special functions
+    - lo function
+    - pack/unpack function
+  - div by 2^n
+  - function results
+  - shift operators
+  - andn optimization
+  - muladdn optimization
+  - comparisations
+- open strings
+- $P
+- range checking for open arrays
+- array of const as subroutine parameter
+- code generation for exceptions
+- initialisation/finalization for units
+- fixed data type
+        - add abstract virtual method runtime
+          error checking (210) ................................... 0.99.1 (FK)
+- add alignment $A switch
+        - add debug info $D switch ............................... 0.99.1 (FK)
+        - add strict var strings check $V switch ................. 0.99.1 (FK)
+- $B
+- fix all bugs of the bug directory
+- include/exclude
+- make dec/inc internal
+- make length internal

compiler/tree.pas

@@ -0,0 +1,1251 @@
+{
+    $Id$
+    Copyright (c) 1993-98 by Florian Klaempfl
+
+    This units exports some routines to manage the parse tree
+
+    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.
+
+ ****************************************************************************
+}
+
+{$ifdef tp}
+  {E+,N+}
+{$endif}
+unit tree;
+
+  interface
+
+    uses
+       objects,globals,symtable,cobjects,verbose,aasm,files
+{$ifdef i386}
+       ,i386
+{$endif}
+{$ifdef m68k}
+       ,m68k
+{$endif}
+{$ifdef alpha}
+       ,alpha
+{$endif}
+       ;
+
+    type
+       tconstset = array[0..31] of byte;
+
+       pconstset = ^tconstset;
+
+       ttreetyp = (addn,            {Represents the + operator.}
+                   muln,            {Represents the * operator.}
+                   subn,            {Represents the - operator.}
+                   divn,            {Represents the div operator.}
+                   symdifn,         {Represents the >< operator.}
+                   modn,            {Represents the mod operator.}
+                   assignn,         {Represents an assignment.}
+                   loadn,           {Represents the use of a variabele.}
+                   rangen,          {Represents a range (i.e. 0..9).}
+                   ltn,             {Represents the < operator.}
+                   lten,            {Represents the <= operator.}
+                   gtn,             {Represents the > operator.}
+                   gten,            {Represents the >= operator.}
+                   equaln,          {Represents the = operator.}
+                   unequaln,        {Represents the <> operator.}
+                   inn,             {Represents the in operator.}
+                   orn,             {Represents the or operator.}
+                   xorn,            {Represents the xor operator.}
+                   shrn,            {Represents the shr operator.}
+                   shln,            {Represents the shl operator.}
+                   slashn,          {Represents the / operator.}
+                   andn,            {Represents the and operator.}
+                   subscriptn,      {??? Field in a record/object?}
+                   derefn,          {Dereferences a pointer.}
+                   addrn,           {Represents the @ operator.}
+                   doubleaddrn,     {Represents the @@ operator.}
+                   ordconstn,       {Represents an ordinal value.}
+                   typeconvn,       {Represents type-conversion/typecast.}
+                   calln,           {Represents a call node.}
+                   callparan,       {Represents a parameter.}
+                   realconstn,      {Represents a real value.}
+                   fixconstn,       {Represents a fixed value.}
+                   umminusn,        {Represents a sign change (i.e. -2).}
+                   asmn,            {Represents an assembler node }
+                   vecn,            {Represents array indexing.}
+                   stringconstn,    {Represents a string constant.}
+                   funcretn,        {Represents the function result var.}
+                   selfn,           {Represents the self parameter.}
+                   notn,            {Represents the not operator.}
+                   inlinen,         {Internal procedures (i.e. writeln).}
+                   niln,            {Represents the nil pointer.}
+                   errorn,          {This part of the tree could not be
+                                     parsed because of a compiler error.}
+                   typen,           {A type name. Used for i.e. typeof(obj).}
+                   hnewn,           {The new operation, constructor call.}
+                   hdisposen,       {The dispose operation with destructor call.}
+                   newn,            {The new operation, constructor call.}
+                   simpledisposen,  {The dispose operation.}
+                   setelen,         {A set element (i.e. [a,b]).}
+                   setconstrn,      {A set constant (i.e. [1,2]).}
+                   blockn,          {A block of statements.}
+                   anwein,          {A linear list of nodes.}
+                   loopn,           { used in genloopnode, must be converted }
+                   ifn,             {An if statement.}
+                   breakn,          {A break statement.}
+                   continuen,       {A continue statement.}
+                   repeatn,         {A repeat until block.}
+                   whilen,          {A while do statement.}
+                   forn,            {A for loop.}
+                   exitn,           {An exit statement.}
+                   withn,           {A with statement.}
+                   casen,           {A case statement.}
+                   labeln,          {A label.}
+                   goton,           {A goto statement.}
+                   simplenewn,      {The new operation.}
+                   tryexceptn,      {A try except block.}
+                   raisen,          {A raise statement.}
+                   switchesn,       {??? Currently unused...}
+                   tryfinallyn,     {A try finally statement.}
+                   isn,             {Represents the is operator.}
+                   asn,             {Represents the as typecast.}
+                   caretn,          {Represents the ^ operator.}
+                   failn,           {Represents the fail statement.}
+                   { added for optimizations where we cannot suppress }
+                   nothingn,
+                   loadvmtn);       {???.}
+
+       tconverttype = (tc_equal,tc_not_possible,tc_u8bit_2_s32bit,
+                      tc_only_rangechecks32bit,tc_s8bit_2_s32bit,
+                      tc_u16bit_2_s32bit,tc_s16bit_2_s32bit,
+                      tc_s32bit_2_s16bit,tc_s32bit_2_u8bit,
+                      tc_s32bit_2_u16bit,tc_string_to_string,
+                      tc_cstring_charpointer,tc_string_chararray,
+                      tc_array_to_pointer,tc_pointer_to_array,
+                      tc_char_to_string,tc_u8bit_2_s16bit,
+                      tc_u8bit_2_u16bit,tc_s8bit_2_s16bit,
+                      tc_s16bit_2_s8bit,tc_s16bit_2_u8bit,
+                      tc_u16bit_2_s8bit,tc_u16bit_2_u8bit,
+                      tc_s8bit_2_u16bit,tc_s32bit_2_s8bit,
+                      tc_s32bit_2_u32bit,tc_s16bit_2_u32bit,
+                      tc_s8bit_2_u32bit,tc_u16bit_2_u32bit,
+                      tc_u8bit_2_u32bit,tc_u32bit_2_s32bit,
+                      tc_int_2_real,tc_real_2_fix,
+                      tc_fix_2_real,tc_int_2_fix,tc_real_2_real,
+                      tc_chararray_2_string,tc_bool_2_u8bit,
+                      tc_proc2procvar,
+                      tc_cchar_charpointer);
+
+       { allows to determine which elementes are to be replaced }
+       tdisposetyp = (dt_nothing,dt_leftright,dt_left,
+                      dt_mbleft,dt_string,dt_typeconv,dt_inlinen,
+                      dt_mbleft_and_method,dt_constset,dt_loop,dt_case,
+                      dt_with);
+
+      { different assignment types }
+
+      tassigntyp = (at_normal,at_plus,at_minus,at_star,at_slash);
+
+      pcaserecord = ^tcaserecord;
+
+      tcaserecord = record
+
+          { range }
+          _low,_high : longint;
+
+          { only used by gentreejmp }
+          _at : plabel;
+
+          { label of instruction }
+          statement : plabel;
+
+          { left and right tree node }
+          less,greater : pcaserecord;
+       end;
+
+       ptree = ^ttree;
+
+       ttree = record
+          error : boolean;
+          disposetyp : tdisposetyp;
+          { is true, if the right and left operand are swaped }
+          swaped : boolean;
+
+          { the location of the result of this node }
+          location : tlocation;
+
+          { the number of registers needed to evalute the node }
+          registers32,registersfpu : longint;  { must be longint !!!! }
+{$ifdef SUPPORT_MMX}
+                  registersmmx : longint;
+{$endif SUPPORT_MMX}
+          left,right : ptree;
+          resulttype : pdef;
+          inputfile : pinputfile;
+          {$ifdef TP}
+          line:word;
+          {$else}
+          line : longint;
+          {$endif}
+          pragmas : Tcswitches;
+{$ifdef extdebug}
+        firstpasscount : longint;
+{$endif extdebug}
+          case treetype : ttreetyp of
+             callparan : (is_colon_para : boolean;exact_match_found : boolean);
+             assignn : (assigntyp : tassigntyp);
+             loadn : (symtableentry : psym;symtable : psymtable;
+                      is_absolute,is_first : boolean);
+             calln : (symtableprocentry : pprocsym;
+                      symtableproc : psymtable;procdefinition : pprocdef;
+                      methodpointer : ptree;
+                      unit_specific : boolean);
+             ordconstn : (value : longint);
+             realconstn : (valued : bestreal;labnumber : longint;realtyp : tait);
+             fixconstn : (valuef: longint);
+{$ifdef TEST_FUNCRET}
+             funcretn : (funcretprocinfo : pointer;retdef : pdef);
+{$endif TEST_FUNCRET}
+             subscriptn : (vs : pvarsym);
+             vecn : (memindex,memseg:boolean);
+             stringconstn : (values : pstring;labstrnumber : longint);
+             typeconvn : (convtyp : tconverttype;explizit : boolean);
+             inlinen : (inlinenumber : longint);
+             { procinlinen : (proc : pprocsym); }
+             setconstrn : (constset : pconstset);
+             loopn : (t1,t2 : ptree;backward : boolean);
+             asmn : (p_asm : paasmoutput);
+             casen : (nodes : pcaserecord;elseblock : ptree);
+             labeln,goton : (labelnr : plabel);
+             withn : (withsymtable : psymtable;tablecount : longint);
+           end;
+
+    procedure init_tree;
+    function gennode(t : ttreetyp;l,r : ptree) : ptree;
+    function genlabelnode(t : ttreetyp;nr : plabel) : ptree;
+    function genloadnode(v : pvarsym;st : psymtable) : ptree;
+    function gensinglenode(t : ttreetyp;l : ptree) : ptree;
+    function gensubscriptnode(varsym : pvarsym;l : ptree) : ptree;
+    function genordinalconstnode(v : longint;def : pdef) : ptree;
+    function genfixconstnode(v : longint;def : pdef) : ptree;
+    function gentypeconvnode(node : ptree;t : pdef) : ptree;
+    function gencallparanode(expr,next : ptree) : ptree;
+    function genrealconstnode(v : bestreal) : ptree;
+    function gencallnode(v : pprocsym;st : psymtable) : ptree;
+    function genmethodcallnode(v : pprocsym;st : psymtable;mp : ptree) : ptree;
+    function genstringconstnode(const s : string) : ptree;
+    function genzeronode(t : ttreetyp) : ptree;
+    function geninlinenode(number : longint;l : ptree) : ptree;
+   {
+   function genprocinlinenode(code : ptree;procsym : pprocsym) : ptree;
+   }
+    function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : ptree;
+    function genenumnode(v : penumsym) : ptree;
+    function genselfnode(_class : pdef) : ptree;
+    function gensetconstruktnode(s : pconstset;settype : psetdef) : ptree;
+    function genloopnode(t : ttreetyp;l,r,n1: ptree;back : boolean) : ptree;
+    function genasmnode(p_asm : paasmoutput) : ptree;
+    function gencasenode(l,r : ptree;nodes : pcaserecord) : ptree;
+    function genwithnode(symtable : psymtable;l,r : ptree;count : longint) : ptree;
+
+    function getcopy(p : ptree) : ptree;
+
+    function equal_trees(t1,t2 : ptree) : boolean;
+
+    procedure disposetree(p : ptree);
+    procedure putnode(p : ptree);
+    function getnode : ptree;
+    procedure clearnodes;
+    procedure set_location(var destloc,sourceloc : tlocation);
+    procedure swap_location(var destloc,sourceloc : tlocation);
+    procedure set_file_line(from,_to : ptree);
+
+{$ifdef extdebug}
+    const
+       maxfirstpasscount : longint = 0;
+{$endif extdebug}
+
+{$I innr.inc}
+
+  implementation
+
+    const
+       oldswitches : tcswitches = [];
+
+{****************************************************************************
+        this is a pool for the tree nodes to get more performance
+ ****************************************************************************}
+
+    var
+       root : ptree;
+
+    procedure init_tree;
+
+      begin
+         root:=nil;
+      end;
+
+    procedure clearnodes;
+
+      var
+         hp : ptree;
+
+      begin
+         hp:=root;
+         while assigned(hp) do
+           begin
+              root:=hp^.left;
+              dispose(hp);
+              hp:=root;
+           end;
+      end;
+
+    function getnode : ptree;
+
+      var
+         hp : ptree;
+
+      begin
+         if root=nil then
+           new(hp)
+         else
+           begin
+              hp:=root;
+              root:=root^.left;
+           end;
+
+         { makes error tracking easier }
+         fillchar(hp^,sizeof(ttree),#0);
+         hp^.location.loc:=LOC_INVALID;
+
+         { new node is error free }
+         hp^.error:=false;
+
+         { we know also the position }
+         hp^.line:=current_module^.current_inputfile^.line_no;
+         hp^.inputfile:=current_module^.current_inputfile;
+         hp^.pragmas:=aktswitches;
+         getnode:=hp;
+      end;
+
+    procedure putnode(p : ptree);
+
+      begin
+         { clean up the contents of a node }
+         if p^.treetype=asmn then
+           if assigned(p^.p_asm) then
+             dispose(p^.p_asm,done);
+
+         if p^.treetype=setconstrn then
+          if assigned(p^.constset) then
+            dispose(p^.constset);
+
+         if (p^.location.loc=LOC_MEM) or (p^.location.loc=LOC_REFERENCE) and
+           assigned(p^.location.reference.symbol) then
+           stringdispose(p^.location.reference.symbol);
+
+         if p^.disposetyp=dt_string then
+           stringdispose(p^.values);
+{$ifdef extdebug}
+         if p^.firstpasscount>maxfirstpasscount then
+            maxfirstpasscount:=p^.firstpasscount;
+         dispose(p);
+{$else extdebug}
+         p^.left:=root;
+         root:=p;
+{$endif extdebug}
+      end;
+
+    function getcopy(p : ptree) : ptree;
+
+      var
+         hp : ptree;
+
+      begin
+         hp:=getnode;
+         hp^:=p^;
+         if assigned(p^.location.reference.symbol) then
+           hp^.location.reference.symbol:=stringdup(p^.location.reference.symbol^);
+         case p^.disposetyp of
+            dt_leftright :
+              begin
+                 if assigned(p^.left) then
+                   hp^.left:=getcopy(p^.left);
+                 if assigned(p^.right) then
+                   hp^.right:=getcopy(p^.right);
+              end;
+            dt_nothing : ;
+            dt_left    :
+              if assigned(p^.left) then
+                hp^.left:=getcopy(p^.left);
+            dt_mbleft :
+              if assigned(p^.left) then
+                hp^.left:=getcopy(p^.left);
+            dt_mbleft_and_method :
+              begin
+                 if assigned(p^.left) then
+                   hp^.left:=getcopy(p^.left);
+                 hp^.methodpointer:=getcopy(p^.methodpointer);
+              end;
+            dt_loop :
+              begin
+                 if assigned(p^.left) then
+                   hp^.left:=getcopy(p^.left);
+                 if assigned(p^.right) then
+                   hp^.right:=getcopy(p^.right);
+                 if assigned(p^.t1) then
+                   hp^.t1:=getcopy(p^.t1);
+                 if assigned(p^.t2) then
+                   hp^.t2:=getcopy(p^.t2);
+              end;
+            dt_string : hp^.values:=stringdup(p^.values^);
+            dt_typeconv : hp^.left:=getcopy(p^.left);
+            dt_inlinen :
+              if assigned(p^.left) then
+                hp^.left:=getcopy(p^.left);
+            else internalerror(11);
+         end;
+         getcopy:=hp;
+      end;
+
+    procedure deletecaselabels(p : pcaserecord);
+
+      begin
+         if assigned(p^.greater) then
+           deletecaselabels(p^.greater);
+         if assigned(p^.less) then
+           deletecaselabels(p^.less);
+         dispose(p);
+      end;
+
+    procedure disposetree(p : ptree);
+
+      begin
+         if not(assigned(p)) then
+           exit;
+         case p^.disposetyp of
+            dt_leftright :
+              begin
+                 if assigned(p^.left) then
+                   disposetree(p^.left);
+                 if assigned(p^.right) then
+                   disposetree(p^.right);
+              end;
+            dt_case :
+              begin
+                 if assigned(p^.left) then
+                   disposetree(p^.left);
+                 if assigned(p^.right) then
+                   disposetree(p^.right);
+                 if assigned(p^.nodes) then
+                   deletecaselabels(p^.nodes);
+                 if assigned(p^.elseblock) then
+                   disposetree(p^.elseblock);
+              end;
+            dt_nothing : ;
+            dt_left    :
+              if assigned(p^.left) then
+                disposetree(p^.left);
+            dt_mbleft :
+              if assigned(p^.left) then
+                disposetree(p^.left);
+            dt_mbleft_and_method :
+              begin
+                 if assigned(p^.left) then disposetree(p^.left);
+                 disposetree(p^.methodpointer);
+              end;
+            dt_string : stringdispose(p^.values);
+            dt_constset :
+              begin
+                 if assigned(p^.constset) then
+                   begin
+                      dispose(p^.constset);
+                      p^.constset:=nil;
+                   end;
+                 if assigned(p^.left) then
+                   disposetree(p^.left);
+              end;
+            dt_typeconv : disposetree(p^.left);
+            dt_inlinen :
+              if assigned(p^.left) then
+                disposetree(p^.left);
+            dt_loop :
+              begin
+                 if assigned(p^.left) then
+                   disposetree(p^.left);
+                 if assigned(p^.right) then
+                   disposetree(p^.right);
+                 if assigned(p^.t1) then
+                   disposetree(p^.t1);
+                 if assigned(p^.t2) then
+                   disposetree(p^.t2);
+              end;
+            dt_with :
+              begin
+                 if assigned(p^.left) then
+                   disposetree(p^.left);
+                 if assigned(p^.right) then
+                   disposetree(p^.right);
+                 if assigned(p^.withsymtable) then
+                   dispose(p^.withsymtable,done);
+              end;
+            else internalerror(12);
+         end;
+         putnode(p);
+      end;
+
+    procedure set_file_line(from,_to : ptree);
+
+      begin
+         if from<>nil then
+           begin
+              _to^.line:=from^.line;
+              _to^.inputfile:=from^.inputfile;
+           end;
+      end;
+
+   function genwithnode(symtable : psymtable;l,r : ptree;count : longint) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_with;
+         p^.treetype:=withn;
+         p^.left:=l;
+         p^.right:=r;
+         p^.registers32:=0;
+         { p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=nil;
+         p^.withsymtable:=symtable;
+         p^.tablecount:=count;
+         set_file_line(l,p);
+         genwithnode:=p;
+      end;
+
+    function genfixconstnode(v : longint;def : pdef) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_nothing;
+         p^.treetype:=fixconstn;
+         p^.registers32:=0;
+         { p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=def;
+         p^.value:=v;
+         genfixconstnode:=p;
+      end;
+
+    function gencallparanode(expr,next : ptree) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_leftright;
+         p^.treetype:=callparan;
+         p^.left:=expr;
+         p^.right:=next;
+         p^.registers32:=0;
+         { p^.registers16:=0;
+         p^.registers8:=0; }
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.registersfpu:=0;
+         p^.resulttype:=nil;
+         p^.exact_match_found:=false;
+         p^.is_colon_para:=false;
+         set_file_line(expr,p);
+         gencallparanode:=p;
+      end;
+
+    function gennode(t : ttreetyp;l,r : ptree) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_leftright;
+         p^.treetype:=t;
+         p^.left:=l;
+         p^.right:=r;
+         p^.registers32:=0;
+         { p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=nil;
+         gennode:=p;
+      end;
+
+    function gencasenode(l,r : ptree;nodes : pcaserecord) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_case;
+         p^.treetype:=casen;
+         p^.left:=l;
+         p^.right:=r;
+         p^.nodes:=nodes;
+         p^.registers32:=0;
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=nil;
+         set_file_line(l,p);
+         gencasenode:=p;
+      end;
+
+    function genloopnode(t : ttreetyp;l,r,n1 : ptree;back : boolean) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_loop;
+         p^.treetype:=t;
+         p^.left:=l;
+         p^.right:=r;
+         p^.t1:=n1;
+         p^.t2:=nil;
+         p^.registers32:=0;
+         p^.backward:=back;
+         { p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=nil;
+         set_file_line(l,p);
+         genloopnode:=p;
+      end;
+
+    function genordinalconstnode(v : longint;def : pdef) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_nothing;
+         p^.treetype:=ordconstn;
+         p^.registers32:=0;
+         { p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=def;
+         p^.value:=v;
+         genordinalconstnode:=p;
+      end;
+
+    function genenumnode(v : penumsym) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_nothing;
+         p^.treetype:=ordconstn;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=v^.definition;
+         p^.value:=v^.value;
+         genenumnode:=p;
+      end;
+
+    function genrealconstnode(v : bestreal) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_nothing;
+         p^.treetype:=realconstn;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+{$ifdef i386}
+         p^.resulttype:=c64floatdef;
+         p^.valued:=v;
+         { default value is double }
+         p^.realtyp:=ait_real_64bit;
+{$endif}
+{$ifdef m68k}
+         p^.resulttype:=new(pfloatdef,init(s32real));
+         p^.valued:=v;
+         { default value is double }
+         p^.realtyp:=ait_real_32bit;
+{$endif}
+         p^.labnumber:=-1;
+         genrealconstnode:=p;
+      end;
+
+    function genstringconstnode(const s : string) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_string;
+         p^.treetype:=stringconstn;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=cstringdef;
+         p^.values:=stringdup(s);
+         p^.labstrnumber:=-1;
+         genstringconstnode:=p;
+      end;
+
+    function gensinglenode(t : ttreetyp;l : ptree) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_left;
+         p^.treetype:=t;
+         p^.left:=l;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=nil;
+         gensinglenode:=p;
+      end;
+
+    function genasmnode(p_asm : paasmoutput) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_nothing;
+         p^.treetype:=asmn;
+         p^.registers32:=4;
+         p^.p_asm:=p_asm;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=8;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=8;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=nil;
+         genasmnode:=p;
+      end;
+
+    function genloadnode(v : pvarsym;st : psymtable) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.treetype:=loadn;
+         p^.resulttype:=v^.definition;
+         p^.symtableentry:=v;
+         p^.symtable:=st;
+         p^.is_first := False;
+         p^.disposetyp:=dt_nothing;
+         genloadnode:=p;
+      end;
+
+    function gentypedconstloadnode(sym : ptypedconstsym;st : psymtable) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.treetype:=loadn;
+         p^.resulttype:=sym^.definition;
+         p^.symtableentry:=pvarsym(sym);
+         p^.symtable:=st;
+         p^.disposetyp:=dt_nothing;
+         gentypedconstloadnode:=p;
+      end;
+
+    function gentypeconvnode(node : ptree;t : pdef) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_typeconv;
+         p^.treetype:=typeconvn;
+         p^.left:=node;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.convtyp:=tc_equal;
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=t;
+         p^.convtyp:=tc_equal;
+         p^.explizit:=false;
+         set_file_line(node,p);
+         gentypeconvnode:=p;
+      end;
+
+    function gencallnode(v : pprocsym;st : psymtable) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.treetype:=calln;
+         p^.symtableprocentry:=v;
+         p^.symtableproc:=st;
+         p^.unit_specific:=false;
+         p^.disposetyp := dt_leftright;
+         p^.methodpointer:=nil;
+         p^.left:=nil;
+         p^.right:=nil;
+         p^.procdefinition:=nil;
+         gencallnode:=p;
+      end;
+
+    function genmethodcallnode(v : pprocsym;st : psymtable;mp : ptree) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.treetype:=calln;
+
+         p^.symtableprocentry:=v;
+         p^.symtableproc:=st;
+         p^.disposetyp:=dt_mbleft_and_method;
+         p^.left:=nil;
+         p^.right:=nil;
+         p^.methodpointer:=mp;
+         p^.procdefinition:=nil;
+         genmethodcallnode:=p;
+      end;
+
+    function gensubscriptnode(varsym : pvarsym;l : ptree) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_left;
+         p^.treetype:=subscriptn;
+         p^.left:=l;
+         p^.registers32:=0;
+         p^.vs:=varsym;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=nil;
+         gensubscriptnode:=p;
+      end;
+
+   function genzeronode(t : ttreetyp) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_nothing;
+         p^.treetype:=t;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=nil;
+         genzeronode:=p;
+      end;
+
+   function genlabelnode(t : ttreetyp;nr : plabel) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_nothing;
+         p^.treetype:=t;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=nil;
+         { for security }
+         { nr^.is_used:=true;}
+         p^.labelnr:=nr;
+         genlabelnode:=p;
+      end;
+
+    function genselfnode(_class : pdef) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_nothing;
+         p^.treetype:=selfn;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=_class;
+         genselfnode:=p;
+      end;
+
+   function geninlinenode(number : longint;l : ptree) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_inlinen;
+         p^.treetype:=inlinen;
+         p^.left:=l;
+         p^.inlinenumber:=number;
+         p^.registers32:=0;
+{         p^.registers16:=0;
+         p^.registers8:=0; }
+         p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=nil;
+         geninlinenode:=p;
+      end;
+
+
+{    function genprocinlinenode(code : ptree;proc : pprocsym) : ptree;
+
+      var
+         p : ptree;
+
+      begin
+         p:=getnode;
+         p^.disposetyp:=dt_inlinen;
+         p^.treetype:=inlinen;
+         p^.inlineproc:=proc;
+         p^.left:=code;
+         p^.registers32:=code^.registers32;
+         p^.registersfpu:=code^.registersfpu;
+$ifdef SUPPORT_MMX
+         p^.registersmmx:=0;
+$endif SUPPORT_MMX
+         p^.resulttype:=proc^.definition^.returntype;
+         genprocinlinenode:=p;
+      end; }
+
+   function gensetconstruktnode(s : pconstset;settype : psetdef) : ptree;
+
+     var
+        p : ptree;
+
+     begin
+        p:=getnode;
+        p^.disposetyp:=dt_constset;
+        p^.treetype:=setconstrn;
+        p^.registers32:=0;
+        p^.registersfpu:=0;
+{$ifdef SUPPORT_MMX}
+         p^.registersmmx:=0;
+{$endif SUPPORT_MMX}
+         p^.resulttype:=settype;
+         p^.left:=nil;
+         new(p^.constset);
+         p^.constset^:=s^;
+         gensetconstruktnode:=p;
+      end;
+
+    function equal_trees(t1,t2 : ptree) : boolean;
+
+      begin
+         if t1^.treetype=t2^.treetype then
+           begin
+              case t1^.treetype of
+                 addn,
+                 muln,
+                 equaln,
+                 orn,
+                 xorn,
+                 andn,
+                 unequaln:
+                   begin
+                      equal_trees:=(equal_trees(t1^.left,t2^.left) and
+                                    equal_trees(t1^.right,t2^.right)) or
+                                   (equal_trees(t1^.right,t2^.left) and
+                                    equal_trees(t1^.left,t2^.right));
+                   end;
+                 subn,
+                 divn,
+                 modn,
+                 assignn,
+                 ltn,
+                 lten,
+                 gtn,
+                 gten,
+                 inn,
+                 shrn,
+                 shln,
+                 slashn,
+                 rangen:
+                   begin
+                      equal_trees:=(equal_trees(t1^.left,t2^.left) and
+                                    equal_trees(t1^.right,t2^.right));
+                   end;
+                 umminusn,
+                 notn,
+                 derefn,
+                 addrn:
+                   begin
+                      equal_trees:=(equal_trees(t1^.left,t2^.left));
+                   end;
+                loadn:
+                   begin
+                      equal_trees:=(t1^.symtableentry=t2^.symtableentry)
+                        { not necessary
+                                     and (t1^.symtable=t2^.symtable)};
+                   end;
+                {
+
+                   subscriptn,
+                   ordconstn,typeconvn,calln,callparan,
+                   realconstn,asmn,vecn,
+                   stringconstn,funcretn,selfn,
+                   inlinen,niln,errorn,
+                   typen,hnewn,hdisposen,newn,
+                   disposen,setelen,setconstrn
+                }
+                else equal_trees:=false;
+             end;
+          end
+        else
+          equal_trees:=false;
+     end;
+
+    {This is needed if you want to be able to delete the string with the nodes !!}
+    procedure set_location(var destloc,sourceloc : tlocation);
+
+      begin
+        if assigned(destloc.reference.symbol) then
+          stringdispose(destloc.reference.symbol);
+        destloc:= sourceloc;
+        if sourceloc.loc in [LOC_MEM,LOC_REFERENCE] then
+          begin
+             if assigned(sourceloc.reference.symbol) then
+               destloc.reference.symbol:=
+                 stringdup(sourceloc.reference.symbol^);
+          end
+        else
+          destloc.reference.symbol:=nil;
+      end;
+
+    procedure swap_location(var destloc,sourceloc : tlocation);
+
+      var
+         swapl : tlocation;
+
+      begin
+         swapl := destloc;
+         destloc := sourceloc;
+         sourceloc := swapl;
+      end;
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:13  root
+  Initial revision
+
+  Revision 1.15  1998/03/24 21:48:36  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.14  1998/03/10 16:27:46  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.13  1998/03/10 01:17:30  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.12  1998/03/02 01:49:37  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.11  1998/02/27 09:26:18  daniel
+  * Changed symtable handling so no junk symtable is put on the symtablestack.
+
+  Revision 1.10  1998/02/13 10:35:54  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.9  1998/02/12 11:50:51  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.8  1998/02/04 14:39:31  florian
+    * small clean up
+
+  Revision 1.7  1998/01/13 23:11:16  florian
+    + class methods
+
+  Revision 1.6  1998/01/11 04:16:36  carl
+  + correct floating point support for m68k
+
+  Revision 1.5  1998/01/07 00:17:11  michael
+  Restored released version (plus fixes) as current
+
+  Revision 1.3  1997/12/04 12:02:15  pierre
+     + added a counter of max firstpass's for a ptree
+       for debugging only in ifdef extdebug
+
+  Revision 1.2  1997/11/29 15:43:08  florian
+  * some minor changes
+
+  Revision 1.1.1.1  1997/11/27 08:33:03  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
+
+    History:
+        19th october 1996:
+            + adapted to version 0.9.0
+         6th september 1997:
+            + added support for MC68000 (CEC)
+         3rd october 1997:
+            + added tc_bool_2_u8bit for in_ord_x (PM)
+         3rd november1997:
+            + added symdifn for sets (PM)
+         13th november 1997:
+            + added partial code for u32bit support (PM)
+}
+

compiler/types.pas

@@ -0,0 +1,992 @@
+{
+    $Id$
+    Copyright (C) 1993-98 by Florian Klaempfl
+
+    This unit provides some help routines for type handling
+
+    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 types;
+
+  interface
+
+    uses
+       objects,cobjects,globals,symtable,tree,aasm;
+
+    type
+       tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
+                   mmxu32bit,mmxs32bit,mmxfixed16,mmxsingle);
+
+    { returns true, if def defines an ordinal type }
+    function is_ordinal(def : pdef) : boolean;
+
+    { true if p points to an open array def }
+    function is_open_array(p : pdef) : boolean;
+
+    { returns true, if def defines a signed data type (only for ordinal types) }
+    function is_signed(def : pdef) : boolean;
+
+    { returns true, if def uses FPU }
+    function is_fpu(def : pdef) : boolean;
+
+    { true if the return value is in EAX }
+    function ret_in_acc(def : pdef) : boolean;
+
+    { true if uses a parameter as return value }
+    function ret_in_param(def : pdef) : boolean;
+
+    { true if a const parameter is too large to copy }
+    function dont_copy_const_param(def : pdef) : boolean;
+    { true if we must never copy this parameter }
+    const
+       never_copy_const_param : boolean = false;
+
+    { true, if def1 and def2 are semantical the same }
+    function is_equal(def1,def2 : pdef) : boolean;
+
+    { checks for type compatibility (subgroups of type)  }
+    { used for case statements... probably missing stuff }
+    { to use on other types                              }
+    function is_subequal(def1, def2: pdef): boolean;
+
+    { true, if two parameter lists are equal }
+    function equal_paras(def1,def2 : pdefcoll) : boolean;
+
+    { gibt den ordinalen Werten der Node zurueck oder falls sie }
+    { keinen ordinalen Wert hat, wird ein Fehler erzeugt        }
+    function get_ordinal_value(p : ptree) : longint;
+
+    { if l isn't in the range of def a range check error is generated }
+    procedure testrange(def : pdef;l : longint);
+
+    { returns the range of def }
+    procedure getrange(def : pdef;var l : longint;var h : longint);
+
+    { generates a VMT for _class }
+    procedure genvmt(_class : pobjectdef);
+
+    { true, if p is a pointer to a const int value }
+    function is_constintnode(p : ptree) : boolean;
+
+    { like is_constintnode }
+    function is_constboolnode(p : ptree) : boolean;
+    function is_constrealnode(p : ptree) : boolean;
+    function is_constcharnode(p : ptree) : boolean;
+
+    { some type helper routines for MMX support }
+    function is_mmx_able_array(p : pdef) : boolean;
+
+    { returns the mmx type }
+    function mmx_type(p : pdef) : tmmxtype;
+
+  implementation
+
+    uses verbose;
+
+    function is_constintnode(p : ptree) : boolean;
+
+      begin
+         {DM: According to me, an orddef with anysize, is
+          a correct constintnode. Anyway I commented changed s32bit check,
+          because it caused problems with statements like a:=high(word).}
+         is_constintnode:=((p^.treetype=ordconstn) and
+           (p^.resulttype^.deftype=orddef) and
+           (porddef(p^.resulttype)^.typ in [u8bit,s8bit,u16bit,s16bit,
+            u32bit,s32bit,uauto]));
+      end;
+
+    function is_constcharnode(p : ptree) : boolean;
+
+      begin
+         is_constcharnode:=((p^.treetype=ordconstn) and
+           (p^.resulttype^.deftype=orddef) and
+           (porddef(p^.resulttype)^.typ=uchar));
+      end;
+
+    function is_constrealnode(p : ptree) : boolean;
+
+      begin
+         is_constrealnode:=(p^.treetype=realconstn);
+      end;
+
+    function is_constboolnode(p : ptree) : boolean;
+
+      begin
+         is_constboolnode:=((p^.treetype=ordconstn) and
+           (p^.resulttype^.deftype=orddef) and
+           (porddef(p^.resulttype)^.typ=bool8bit));
+      end;
+
+    function equal_paras(def1,def2 : pdefcoll) : boolean;
+
+      begin
+         while (assigned(def1)) and (assigned(def2)) do
+           begin
+              if not(is_equal(def1^.data,def2^.data)) or
+                 (def1^.paratyp<>def2^.paratyp) then
+                begin
+                   equal_paras:=false;
+                   exit;
+                end;
+              def1:=def1^.next;
+              def2:=def2^.next;
+           end;
+         if (def1=nil) and (def2=nil) then
+           equal_paras:=true
+         else
+           equal_paras:=false;
+      end;
+
+    { returns true, if def uses FPU }
+    function is_fpu(def : pdef) : boolean;
+      begin
+         is_fpu:=(def^.deftype=floatdef) and (pfloatdef(def)^.typ<>f32bit);
+      end;
+    function is_ordinal(def : pdef) : boolean;
+
+      var
+         dt : tbasetype;
+
+      begin
+         case def^.deftype of
+            orddef : begin
+                          dt:=porddef(def)^.typ;
+                          is_ordinal:=(dt=s32bit) or (dt=u32bit) or (dt=uchar) or (dt=u8bit) or
+                            (dt=s8bit) or (dt=s16bit) or (dt=bool8bit) or (dt=u16bit);
+                       end;
+            enumdef : is_ordinal:=true;
+            else is_ordinal:=false;
+         end;
+      end;
+
+    function is_signed(def : pdef) : boolean;
+
+      var
+         dt : tbasetype;
+
+      begin
+         case def^.deftype of
+            orddef : begin
+                          dt:=porddef(def)^.typ;
+                          is_signed:=(dt=s32bit) or (dt=s8bit) or (dt=s16bit);
+                       end;
+            enumdef : is_signed:=false;
+            else internalerror(1001);
+         end;
+      end;
+
+    { true, if p points to an open array def }
+    function is_open_array(p : pdef) : boolean;
+
+      begin
+         is_open_array:=(p^.deftype=arraydef) and
+                 (parraydef(p)^.lowrange=0) and
+                 (parraydef(p)^.highrange=-1);
+      end;
+
+    { true if the return value is in accumulator (EAX for i386), D0 for 68k }
+    function ret_in_acc(def : pdef) : boolean;
+
+      begin
+         ret_in_acc:=(def^.deftype=orddef) or
+                     (def^.deftype=pointerdef) or
+                     (def^.deftype=enumdef) or
+                     (def^.deftype=procvardef) or
+                     (def^.deftype=classrefdef) or
+                     ((def^.deftype=objectdef) and
+                      ((pobjectdef(def)^.options and oois_class)<>0)
+                     ) or
+                     ((def^.deftype=setdef) and
+                      (psetdef(def)^.settype=smallset)) or
+                     ((def^.deftype=floatdef) and
+                      (pfloatdef(def)^.typ=f32bit));
+      end;
+
+    { true if uses a parameter as return value }
+    function ret_in_param(def : pdef) : boolean;
+
+      begin
+         ret_in_param:=(def^.deftype=arraydef) or
+                       (def^.deftype=stringdef) or
+                       ((def^.deftype=objectdef) and
+                        ((pobjectdef(def)^.options and oois_class)=0)
+                       ) or
+                       (def^.deftype=recorddef) or
+                       ((def^.deftype=setdef) and
+                        (psetdef(def)^.settype<>smallset));
+      end;
+
+    { true if a const parameter is too large to copy }
+    function dont_copy_const_param(def : pdef) : boolean;
+
+      begin
+         dont_copy_const_param:=(def^.deftype=arraydef) or
+                       (def^.deftype=stringdef) or
+                       (def^.deftype=objectdef) or
+                       (def^.deftype=formaldef) or
+                       (def^.deftype=recorddef) or
+                       (def^.deftype=formaldef) or
+                       ((def^.deftype=setdef) and
+                        (psetdef(def)^.settype<>smallset));
+      end;
+
+    procedure testrange(def : pdef;l : longint);
+
+      var
+         lv,hv: longint;
+
+      begin
+         getrange(def,lv,hv);
+         if (def^.deftype=orddef) and
+            (porddef(def)^.typ=u32bit) then
+           begin
+              if lv<=hv then
+                begin
+                   if (l<lv) or (l>hv) then
+                    Message(parser_e_range_check_error);
+                end
+              else
+                { this happens with the wrap around problem  }
+                { if lv is positive and hv is over $7ffffff  }
+                { so it seems negative                       }
+                begin
+                   if ((l>=0) and (l<lv)) or
+                      ((l<0) and (l>hv)) then
+                    Message(parser_e_range_check_error);
+                end;
+           end
+         else if (l<lv) or (l>hv) then
+           Message(parser_e_range_check_error);
+      end;
+
+    procedure getrange(def : pdef;var l : longint;var h : longint);
+
+      begin
+         if def^.deftype=orddef then
+           case porddef(def)^.typ of
+              s32bit,s16bit,u16bit,s8bit,u8bit :
+                begin
+                   l:=porddef(def)^.von;
+                   h:=porddef(def)^.bis;
+                end;
+              bool8bit : begin
+                            l:=0;
+                            h:=1;
+                         end;
+              uchar : begin
+                         l:=0;
+                         h:=255;
+                      end;
+              u32bit : begin
+                          { this should work now }
+                          l:=porddef(def)^.von;
+                          h:=porddef(def)^.bis;
+                       end;
+           end
+         else
+           if def^.deftype=enumdef then
+             begin
+                l:=0;
+                h:=penumdef(def)^.max;
+             end;
+      end;
+
+    function get_ordinal_value(p : ptree) : longint;
+
+      begin
+         if p^.treetype=ordconstn then
+           get_ordinal_value:=p^.value
+         else
+           Message(parser_e_ordinal_expected);
+      end;
+
+    function mmx_type(p : pdef) : tmmxtype;
+
+      begin
+         mmx_type:=mmxno;
+         if is_mmx_able_array(p) then
+           begin
+              if parraydef(p)^.definition^.deftype=floatdef then
+                case pfloatdef(parraydef(p)^.definition)^.typ of
+                  s32real:
+                    mmx_type:=mmxsingle;
+                  f16bit:
+                    mmx_type:=mmxfixed16
+                end
+              else
+                case porddef(parraydef(p)^.definition)^.typ of
+                   u8bit:
+                     mmx_type:=mmxu8bit;
+                   s8bit:
+                     mmx_type:=mmxs8bit;
+                   u16bit:
+                     mmx_type:=mmxu16bit;
+                   s16bit:
+                     mmx_type:=mmxs16bit;
+                   u32bit:
+                     mmx_type:=mmxu32bit;
+                   s32bit:
+                     mmx_type:=mmxs32bit;
+                end;
+           end;
+      end;
+
+    function is_mmx_able_array(p : pdef) : boolean;
+
+      begin
+{$ifdef SUPPORT_MMX}
+         if (cs_mmx_saturation in aktswitches) then
+           begin
+              is_mmx_able_array:=(p^.deftype=arraydef) and
+                (
+                 ((parraydef(p)^.definition^.deftype=orddef) and
+                  (
+                  (parraydef(p)^.lowrange=0) and
+                  (parraydef(p)^.highrange=1) and
+                  (porddef(parraydef(p)^.definition)^.typ in [u32bit,s32bit])
+                  ) or
+                  (
+                  (parraydef(p)^.lowrange=0) and
+                  (parraydef(p)^.highrange=3) and
+                  (porddef(parraydef(p)^.definition)^.typ in [u16bit,s16bit])
+                  )
+                 )
+                ) or
+                (
+                 ((parraydef(p)^.definition^.deftype=floatdef) and
+                  (
+                   (parraydef(p)^.lowrange=0) and
+                   (parraydef(p)^.highrange=3) and
+                   (pfloatdef(parraydef(p)^.definition)^.typ=f16bit)
+                  ) or
+                  (
+                   (parraydef(p)^.lowrange=0) and
+                   (parraydef(p)^.highrange=1) and
+                   (pfloatdef(parraydef(p)^.definition)^.typ=s32real)
+                  )
+                 )
+                );
+           end
+         else
+           begin
+              is_mmx_able_array:=(p^.deftype=arraydef) and
+                (
+                 ((parraydef(p)^.definition^.deftype=orddef) and
+                  (
+                  (parraydef(p)^.lowrange=0) and
+                  (parraydef(p)^.highrange=1) and
+                  (porddef(parraydef(p)^.definition)^.typ in [u32bit,s32bit])
+                  ) or
+                  (
+                  (parraydef(p)^.lowrange=0) and
+                  (parraydef(p)^.highrange=3) and
+                  (porddef(parraydef(p)^.definition)^.typ in [u16bit,s16bit])
+                  ) or
+                  (
+                  (parraydef(p)^.lowrange=0) and
+                  (parraydef(p)^.highrange=7) and
+                  (porddef(parraydef(p)^.definition)^.typ in [u8bit,s8bit])
+                  )
+                 )
+                ) or
+                (
+                 ((parraydef(p)^.definition^.deftype=floatdef) and
+                  (
+                   (parraydef(p)^.lowrange=0) and
+                   (parraydef(p)^.highrange=3) and
+                   (pfloatdef(parraydef(p)^.definition)^.typ=f32bit)
+                  )
+                  or
+                  (
+                   (parraydef(p)^.lowrange=0) and
+                   (parraydef(p)^.highrange=1) and
+                   (pfloatdef(parraydef(p)^.definition)^.typ=s32real)
+                  )
+                 )
+                );
+           end;
+{$else SUPPORT_MMX}
+         is_mmx_able_array:=false;
+{$endif SUPPORT_MMX}
+      end;
+
+    function is_equal(def1,def2 : pdef) : boolean;
+
+      var
+         b : boolean;
+         hd : pdef;
+         hp1,hp2 : pdefcoll;
+
+      begin
+         { be sure, that if there is a stringdef, that this is def1 }
+         if def2^.deftype=stringdef then
+           begin
+              hd:=def1;
+              def1:=def2;
+              def2:=hd;
+           end;
+         b:=false;
+
+         { wenn beide auf die gleiche Definition zeigen sind sie wohl gleich...}
+         if def1=def2 then
+           b:=true
+         else
+         { pointer with an equal definition are equal }
+           if (def1^.deftype=pointerdef) and (def2^.deftype=pointerdef) then
+         { here a problem detected in tabsolutesym }
+         { the types can be forward type !!        }
+             begin
+                if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
+                  b:=(def1^.sym=def2^.sym)
+                else
+                  b:=is_equal(ppointerdef(def1)^.definition,ppointerdef(def2)^.definition);
+             end
+         else
+         { Grundtypen sind gleich, wenn sie den selben Grundtyp haben, }
+         { und wenn noetig den selben Unterbereich haben }
+           if (def1^.deftype=orddef) and (def2^.deftype=orddef) then
+             begin
+                case porddef(def1)^.typ of
+                   u32bit,u8bit,s32bit,s8bit,u16bit,s16bit : begin
+                                     if porddef(def1)^.typ=porddef(def2)^.typ then
+                                       if (porddef(def1)^.von=porddef(def2)^.von) and
+                                          (porddef(def1)^.bis=porddef(def2)^.bis) then
+                                           b:=true;
+                                  end;
+                   uvoid,bool8bit,uchar :
+                     b:=porddef(def1)^.typ=porddef(def2)^.typ;
+                end;
+             end
+         else
+           if (def1^.deftype=floatdef) and (def2^.deftype=floatdef) then
+             b:=pfloatdef(def1)^.typ=pfloatdef(def2)^.typ
+         else
+            { strings with the same length are equal }
+            if (def1^.deftype=stringdef) and (def2^.deftype=stringdef) and
+               (pstringdef(def1)^.len=pstringdef(def2)^.len) then
+            b:=true
+    { STRING[N] ist equivalent zu ARRAY[0..N] OF CHAR (N<256) }
+{
+         else if ((def1^.deftype=stringdef) and (def2^.deftype=arraydef)) and
+              (parraydef(def2)^.definition^.deftype=orddef) and
+              (porddef(parraydef(def1)^.definition)^.typ=uchar) and
+              (parraydef(def2)^.lowrange=0) and
+              (parraydef(def2)^.highrange=pstringdef(def1)^.len) then
+              b:=true }
+          else
+            if (def1^.deftype=formaldef) and (def2^.deftype=formaldef) then
+              b:=true
+          { file types with the same file element type are equal }
+          { this is a problem for assign !!                      }
+          { changed to allow if one is untyped                   }
+          { all typed files are equal to the special             }
+          { typed file that has voiddef as elemnt type           }
+          { but must NOT match for text file !!!                 }
+          else
+            if (def1^.deftype=filedef) and (def2^.deftype=filedef) then
+              b:=(pfiledef(def1)^.filetype=pfiledef(def2)^.filetype) and
+                 ((
+                 ((pfiledef(def1)^.typed_as=nil) and
+                  (pfiledef(def2)^.typed_as=nil)) or
+                 (
+                  (pfiledef(def1)^.typed_as<>nil) and
+                  (pfiledef(def2)^.typed_as<>nil) and
+                  is_equal(pfiledef(def1)^.typed_as,pfiledef(def2)^.typed_as)
+                 ) or
+                 ( (pfiledef(def1)^.typed_as=pdef(voiddef)) or
+                   (pfiledef(def2)^.typed_as=pdef(voiddef))
+                 )))
+          { sets with the same element type are equal }
+          else
+            if (def1^.deftype=setdef) and (def2^.deftype=setdef) then
+              begin
+                 if assigned(psetdef(def1)^.setof) and
+                    assigned(psetdef(def2)^.setof) then
+                   b:=is_equal(psetdef(def1)^.setof,psetdef(def2)^.setof)
+                 else b:=true;
+              end
+          else
+            if (def1^.deftype=procvardef) and (def2^.deftype=procvardef) then
+              begin
+                 { poassembler isn't important for compatibility }
+                 b:=((pprocvardef(def1)^.options and not(poassembler))=
+                     (pprocvardef(def2)^.options and not(poassembler))
+                    ) and
+                   is_equal(pprocvardef(def1)^.retdef,pprocvardef(def2)^.retdef);
+                 { now evalute the parameters }
+                 if b then
+                   begin
+                      hp1:=pprocvardef(def1)^.para1;
+                      hp2:=pprocvardef(def1)^.para1;
+                      while assigned(hp1) and assigned(hp2) do
+                        begin
+                           if not(is_equal(hp1^.data,hp2^.data)) or
+                             not(hp1^.paratyp=hp2^.paratyp) then
+                             begin
+                                b:=false;
+                                break;
+                             end;
+                           hp1:=hp1^.next;
+                           hp2:=hp2^.next;
+                        end;
+                      b:=(hp1=nil) and (hp2=nil);
+                   end;
+              end
+          else
+            if (def1^.deftype=arraydef) and (def2^.deftype=arraydef) and
+              (is_open_array(def1) or is_open_array(def2)) then
+              begin
+                 b:=is_equal(parraydef(def1)^.definition,parraydef(def2)^.definition);
+              end
+          else
+            if (def1^.deftype=classrefdef) and (def2^.deftype=classrefdef) then
+              begin
+                 { similar to pointerdef: }
+                 if assigned(def1^.sym) and ((def1^.sym^.properties and sp_forwarddef)<>0) then
+                   b:=(def1^.sym=def2^.sym)
+                 else
+                   b:=is_equal(pclassrefdef(def1)^.definition,pclassrefdef(def2)^.definition);
+              end;
+         is_equal:=b;
+      end;
+
+
+    function is_subequal(def1, def2: pdef): boolean;
+    Begin
+      if assigned(def1) and assigned(def2) then
+      Begin
+        is_subequal := FALSE;
+        if (def1^.deftype = orddef) and (def2^.deftype = orddef) then
+          Begin
+            { see p.47 of Turbo Pascal 7.01 manual for the separation of types }
+            { range checking for case statements is done with testrange        }
+            case porddef(def1)^.typ of
+              s32bit,u32bit,u8bit,s8bit,s16bit,u16bit:
+                Begin
+{ PROBABLE CODE GENERATION BUG HERE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! }
+{                   if porddef(def2)^.typ in [s32bit,u32bit,u8bit,s8bit,s16bit,u16bit] then
+                     is_subequal := TRUE; }
+                    if (porddef(def2)^.typ = s32bit) or
+                       (porddef(def2)^.typ = u32bit) or
+                       (porddef(def2)^.typ = u8bit) or
+                       (porddef(def2)^.typ = s8bit) or
+                       (porddef(def2)^.typ = s16bit) or
+                       (porddef(def2)^.typ = u16bit) then
+                     Begin
+                       is_subequal:=TRUE;
+                     end;
+                end;
+              bool8bit: if porddef(def2)^.typ = bool8bit then is_subequal := TRUE;
+              uchar: if porddef(def2)^.typ = uchar then is_subequal := TRUE;
+            end;
+          end
+        else
+          Begin
+            { I assume that both enumerations are equal when the first }
+            { pointers are equal.                                      }
+            if (def1^.deftype = enumdef) and (def2^.deftype =enumdef) then
+              Begin
+                if penumdef(def1)^.first = penumdef(def2)^.first then
+                   is_subequal := TRUE;
+              end;
+          end;
+      end; { endif assigned ... }
+    end;
+
+    type
+       pprocdefcoll = ^tprocdefcoll;
+
+       tprocdefcoll = record
+          next : pprocdefcoll;
+          data : pprocdef;
+       end;
+
+       psymcoll = ^tsymcoll;
+
+       tsymcoll = record
+          next : psymcoll;
+          name : pstring;
+          data : pprocdefcoll;
+       end;
+
+    var
+       wurzel : psymcoll;
+       nextvirtnumber : longint;
+       _c : pobjectdef;
+       has_constructor,has_virtual_method : boolean;
+
+    procedure eachsym(sym : psym);{$ifndef FPC}far;{$endif}
+
+      var
+         procdefcoll : pprocdefcoll;
+         hp : pprocdef;
+         symcoll : psymcoll;
+         _name : string;
+         stored : boolean;
+
+      begin
+         { nur Unterprogrammsymbole werden in die VMT aufgenommen }
+         if sym^.typ=procsym then
+           begin
+              _name:=sym^.name;
+              symcoll:=wurzel;
+              while assigned(symcoll) do
+                begin
+                   { wenn das Symbol in der Liste schon existiert }
+                   if _name=symcoll^.name^ then
+                     begin
+                        { walk thorugh all defs of the symbol }
+                        hp:=pprocsym(sym)^.definition;
+                        while assigned(hp) do
+                          begin
+                             { compare with all stored definitions }
+                             procdefcoll:=symcoll^.data;
+                             stored:=false;
+                             while assigned(procdefcoll) do
+                               begin
+                                  { compare parameters }
+                                  if equal_paras(procdefcoll^.data^.para1,hp^.para1) and
+                                     (
+                                       ((procdefcoll^.data^.options and povirtualmethod)<>0) or
+                                       ((hp^.options and povirtualmethod)<>0)
+                                     ) then
+                                    begin
+                                       { wenn sie gleich sind }
+                                       { und eine davon virtual deklariert ist }
+                                       { Fehler falls nur eine VIRTUAL }
+                                       if (procdefcoll^.data^.options and povirtualmethod)<>
+                                          (hp^.options and povirtualmethod) then
+                                            Message1(parser_e_overloaded_are_not_both_virtual,_c^.name^+'.'+_name);
+
+                                       { check, if the overridden directive is set }
+                                       { (povirtualmethod is set! }
+
+                                       { class ? }
+                                       if ((_c^.options and oois_class)<>0) and
+                                         ((hp^.options and pooverridingmethod)=0) then
+                                            Message1(parser_e_must_use_override,_c^.name^+'.'+_name);
+
+                                       { error, if the return types aren't equal }
+                                       if not(is_equal(procdefcoll^.data^.retdef,hp^.retdef)) then
+                                         Message1(parser_e_overloaded_methodes_not_same_ret,_c^.name^+'.'+_name);
+
+
+                                       { the flags have to match      }
+                                       { except abstract and override }
+                                       if (procdefcoll^.data^.options and not(poabstractmethod or pooverridingmethod))<>
+                                         (hp^.options and not(poabstractmethod or pooverridingmethod)) then
+                                            Message1(parser_e_header_dont_match_forward,_c^.name^+'.'+_name);
+
+                                       { now set the number }
+                                       hp^.extnumber:=procdefcoll^.data^.extnumber;
+                                       { and exchange }
+                                       procdefcoll^.data:=hp;
+                                       stored:=true;
+                                    end;
+                                  procdefcoll:=procdefcoll^.next;
+                               end;
+                             { if it isn't saved in the list }
+                             { we create a new entry         }
+                             if not(stored) then
+                               begin
+                                  new(procdefcoll);
+                                  procdefcoll^.data:=hp;
+                                  procdefcoll^.next:=symcoll^.data;
+                                  symcoll^.data:=procdefcoll;
+                                  { if the method is virtual ... }
+                                  if (hp^.options and povirtualmethod)<>0 then
+                                    begin
+                                       { ... it will get a number }
+                                       hp^.extnumber:=nextvirtnumber;
+                                       inc(nextvirtnumber);
+                                    end;
+                                  { check, if a method should be overridden }
+                                  if (hp^.options and pooverridingmethod)<>0 then
+                                   Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
+                               end;
+                             hp:=hp^.nextoverloaded;
+                          end;
+                        exit;
+                     end;
+                   symcoll:=symcoll^.next;
+                end;
+              { if not, generate a new symbol item }
+              new(symcoll);
+              symcoll^.name:=stringdup(sym^.name);
+              symcoll^.next:=wurzel;
+              symcoll^.data:=nil;
+              wurzel:=symcoll;
+              hp:=pprocsym(sym)^.definition;
+
+              { inserts all definitions }
+              while assigned(hp) do
+                begin
+                   new(procdefcoll);
+                   procdefcoll^.data:=hp;
+                   procdefcoll^.next:=symcoll^.data;
+                   symcoll^.data:=procdefcoll;
+
+                   { if it's a virtual method }
+                   if (hp^.options and povirtualmethod)<>0 then
+                     begin
+                        { then it gets a number ... }
+                        hp^.extnumber:=nextvirtnumber;
+                        { and we inc the number }
+                        inc(nextvirtnumber);
+                        has_virtual_method:=true;
+                     end;
+
+                   if (hp^.options and poconstructor)<>0 then
+                     has_constructor:=true;
+
+                   { check, if a method should be overridden }
+                   if (hp^.options and pooverridingmethod)<>0 then
+                     Message1(parser_e_nothing_to_be_overridden,_c^.name^+'.'+_name);
+                   { next overloaded method }
+                   hp:=hp^.nextoverloaded;
+                end;
+           end;
+      end;
+
+    procedure genvmt(_class : pobjectdef);
+
+      procedure do_genvmt(p : pobjectdef);
+
+        begin
+           { start with the base class }
+           if assigned(p^.childof) then
+             do_genvmt(p^.childof);
+
+           { walk through all public syms }
+           _c:=_class;
+{$ifdef tp}
+           p^.publicsyms^.foreach(eachsym);
+{$else}
+           p^.publicsyms^.foreach(@eachsym);
+{$endif}
+        end;
+
+      var
+         symcoll : psymcoll;
+         procdefcoll : pprocdefcoll;
+         i : longint;
+
+      begin
+         wurzel:=nil;
+         nextvirtnumber:=0;
+
+         has_constructor:=false;
+         has_virtual_method:=false;
+
+         { generates a tree of all used methods }
+         do_genvmt(_class);
+
+         if has_virtual_method and not(has_constructor) then
+           begin
+              exterror:=strpnew(_class^.name^);
+              Message(parser_w_virtual_without_constructor);
+           end;
+         { generates the VMT }
+
+         { walk trough all numbers for virtual methods and search }
+         { the method                                             }
+         for i:=0 to nextvirtnumber-1 do
+           begin
+              symcoll:=wurzel;
+
+              { walk trough all symbols }
+              while assigned(symcoll) do
+                begin
+
+                   { walk trough all methods }
+                   procdefcoll:=symcoll^.data;
+                   while assigned(procdefcoll) do
+                     begin
+                        { writes the addresses to the VMT }
+                        { but only this which are declared as virtual }
+                        if procdefcoll^.data^.extnumber=i then
+                          begin
+                             if (procdefcoll^.data^.options and povirtualmethod)<>0 then
+                               begin
+                                  { if a method is abstract, then is also the }
+                                  { class abstract and it's not allow to      }
+                                  { generates an instance                     }
+                                  if (procdefcoll^.data^.options and poabstractmethod)<>0 then
+                                    begin
+                                       _class^.options:=_class^.options or oois_abstract;
+                                       datasegment^.concat(new(pai_const,init_symbol('ABSTRACTERROR')));
+                                    end
+                                  else
+                                    datasegment^.concat(new(pai_const,init_symbol(
+                                      strpnew(procdefcoll^.data^.mangledname))));
+                               end;
+                          end;
+                        procdefcoll:=procdefcoll^.next;
+                     end;
+                   symcoll:=symcoll^.next;
+                end;
+           end;
+         { disposes the above generated tree }
+         symcoll:=wurzel;
+         while assigned(symcoll) do
+           begin
+              wurzel:=symcoll^.next;
+              stringdispose(symcoll^.name);
+              procdefcoll:=symcoll^.data;
+              while assigned(procdefcoll) do
+                begin
+                   symcoll^.data:=procdefcoll^.next;
+                   dispose(procdefcoll);
+                   procdefcoll:=symcoll^.data;
+                end;
+              dispose(symcoll);
+              symcoll:=wurzel;
+           end;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.24  1998/03/21 23:59:40  florian
+    * indexed properties fixed
+    * ppu i/o of properties fixed
+    * field can be also used for write access
+    * overriding of properties
+
+  Revision 1.23  1998/03/20 23:31:35  florian
+    * bug0113 fixed
+    * problem with interdepened units fixed ("options.pas problem")
+    * two small extensions for future AMD 3D support
+
+  Revision 1.22  1998/03/10 01:17:30  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.21  1998/03/06 01:09:01  peter
+    * removed the conflicts that had occured
+
+  Revision 1.20  1998/03/06 00:53:01  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.19  1998/03/05 22:40:56  florian
+    + warning about missing constructor added
+
+  Revision 1.18  1998/03/04 17:34:14  michael
+  + Changed ifdef FPK to ifdef FPC
+
+  Revision 1.17  1998/03/02 01:49:38  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.16  1998/02/13 10:35:55  daniel
+  * Made Motorola version compilable.
+  * Fixed optimizer
+
+  Revision 1.15  1998/02/12 17:19:33  florian
+    * fixed to get remake3 work, but needs additional fixes (output, I don't like
+      also that aktswitches isn't a pointer)
+
+  Revision 1.14  1998/02/12 11:50:52  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/11 21:56:41  florian
+    * bugfixes: bug0093, bug0053, bug0088, bug0087, bug0089
+
+  Revision 1.12  1998/02/07 23:05:08  florian
+    * once more MMX
+
+  Revision 1.11  1998/02/06 10:34:35  florian
+    * bug0082 and bug0084 fixed
+
+  Revision 1.10  1998/02/05 22:27:07  florian
+    * small problems fixed: remake3 should now work
+
+  Revision 1.9  1998/02/05 21:54:36  florian
+    + more MMX
+
+  Revision 1.8  1998/01/31 00:43:37  carl
+    - removed in in is_subequal, because the code generator is buggy!
+      (instead uses if...)
+
+  Revision 1.7  1998/01/16 18:03:21  florian
+    * small bug fixes, some stuff of delphi styled constructores added
+
+  Revision 1.6  1998/01/11 19:24:35  carl
+    + type checking routine (is_subequal) for case statements
+
+  Revision 1.5  1998/01/09 23:08:38  florian
+    + C++/Delphi styled //-comments
+    * some bugs in Delphi object model fixed
+    + override directive
+
+  Revision 1.4  1998/01/09 16:08:24  florian
+    * abstract methods call now abstracterrorproc if they are called
+      a class with an abstract method can be create with a class reference else
+      the compiler forbides this
+
+  Revision 1.3  1998/01/07 00:17:12  michael
+  Restored released version (plus fixes) as current
+
+  Revision 1.2  1997/11/28 18:14:51  pierre
+   working version with several bug fixes
+
+  Revision 1.1.1.1  1997/11/27 08:33:03  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
+
+  History:
+      22th september 1997
+         + function dont_copy_const_param added (FK)
+      25th september 1997
+         + is_open_array added (FK)
+         + is_equal handles now also open arrays (FK)
+      2nd october 1997
+         + added then boolean never_copy_const_param for use in typed write
+           where we must push the reference anyway (PM)
+      3rd october 1997:
+         + renamed ret_in_eax to ret_in_acc (for accumulator for port.) (CEC)
+         - removed reference to i386 unit (CEC)
+     25th october 1997:
+         * poassembler isn't important for compatiblity of proc vars (FK)
+      3rd november 1997:
+         + added formaldef type to types where we dont_copy_const_param (PM)
+      20rd november 1997:
+         + added is_fpu function (PM)
+}

compiler/verb_def.pas

@@ -0,0 +1,270 @@
+{
+    $Id$
+    Copyright (c) 1998 by Peter Vreman
+
+    This unit handles the default verbose routines
+
+    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 verb_def;
+interface
+uses verbose;
+
+{$define allow_oldstyle}
+
+var
+  UseStdErr : boolean;
+procedure SetRedirectFile(const fn:string);
+
+procedure _stop;
+procedure _comment(Level:Longint;const s:string);
+{$ifdef allow_oldstyle}
+function _warning(w : tmsgconst) : boolean;
+function _note(w : tmsgconst) : boolean;
+function _error(w : tmsgconst) : boolean;
+function _fatalerror(w : tmsgconst) : boolean;
+function _internalerror(i : longint) : boolean;
+{$endif}
+
+implementation
+uses
+  strings,dos,cobjects,systems,globals,files;
+
+const
+{$ifdef USE_RHIDE}
+  { RHIDE expect gcc like error output }
+  fatalstr='fatal: ';
+  errorstr='error: ';
+  warningstr='warning: ';
+  notestr='warning: ';
+  hintstr='warning: ';
+{$else}
+  fatalstr='Fatal Error: ';
+  errorstr='Error: ';
+  warningstr='Warning: ';
+  notestr='Note: ';
+  hintstr='Hint: ';
+{$endif USE_RHIDE}
+
+var
+  redirexitsave : pointer;
+  redirtext : boolean;
+  redirfile : text;
+
+{****************************************************************************
+                       Extra Handlers for default compiler
+****************************************************************************}
+
+procedure DoneRedirectFile;{$ifndef FPC}far;{$ENDIF}
+begin
+  exitproc:=redirexitsave;
+  if redirtext then
+   close(redirfile);
+end;
+
+
+procedure SetRedirectFile(const fn:string);
+begin
+  assign(redirfile,fn);
+  {$I-}
+   rewrite(redirfile);
+  {$I+}
+  redirtext:=(ioresult=0);
+  if redirtext then
+   begin
+     redirexitsave:=exitproc;
+     exitproc:=@DoneRedirectFile;
+   end;
+end;
+
+
+{****************************************************************************
+                         Predefined default Handlers
+****************************************************************************}
+
+
+{ predefined handler to stop the compiler }
+procedure _stop;
+begin
+  halt(1);
+end;
+
+
+Procedure _comment(Level:Longint;const s:string);
+var
+  hs : string;
+{$ifdef USE_RHIDE}
+  i  : longint;
+{$endif}
+begin
+  if (verbosity and Level)=Level then
+   begin
+   {Create hs}
+     hs:='';
+     if (verbosity and Level)=V_Hint then
+      hs:=hintstr;
+     if (verbosity and Level)=V_Note then
+      hs:=notestr;
+     if (verbosity and Level)=V_Warning then
+      hs:=warningstr;
+     if (verbosity and Level)=V_Error then
+      hs:=errorstr;
+     if (verbosity and Level)=V_Fatal then
+      hs:=fatalstr;
+     if (Level<$100) and Assigned(current_module) and
+        Assigned(current_module^.current_inputfile) then
+      hs:=current_module^.current_inputfile^.get_file_line+' '+hs;
+{$ifdef USE_RHIDE}
+     if (Level<$100) then
+      begin
+        i:=length(hs)+1;
+        hs:=hs+lowercase(Copy(s,1,5))+Copy(s,6,255);
+      end
+     else
+{$endif USE_RHIDE}
+      hs:=hs+s;
+{$ifdef FPC}
+     if UseStdErr and (Level<$100) then
+      begin
+        writeln(stderr,hs);
+        flush(stderr);
+      end
+     else
+{$ENDIF}
+      begin
+        if redirtext then
+         writeln(redirfile,hs)
+        else
+         writeln(hs);
+      end;
+   end;
+end;
+
+
+function _internalerror(i : longint) : boolean;
+var
+  temp : string;
+begin
+  if assigned(current_module^.current_inputfile) then
+   temp:=current_module^.current_inputfile^.get_file_line+': '
+  else
+   temp:='';
+  comment(V_Error,temp+'Internal error '+tostr(i));
+  _internalerror:=true;
+end;
+
+{****************************************************************************
+                                 Old Style
+****************************************************************************}
+
+
+{$ifdef allow_oldstyle}
+
+procedure ShowExtError(l:longint;w:tmsgconst);
+var
+  s : string;
+begin
+{fix the string to be written }
+  s:=msg^.get(ord(w));
+  if assigned(exterror) then
+   begin
+     s:=s+strpas(exterror);
+     strdispose(exterror);
+     exterror:=nil;
+   end;
+  _comment(l,s);
+end;
+
+
+{ predefined handler for warnings }
+function _warning(w : tmsgconst) : boolean;
+begin
+  ShowExtError(V_Warning,w);
+  _warning:=false;
+end;
+
+
+function _note(w : tmsgconst) : boolean;
+begin
+  ShowExtError(V_Note,w);
+  _note:=false;
+end;
+
+
+function _error(w : tmsgconst) : boolean;
+begin
+  ShowExtError(V_Error,w);
+  _error:=(errorcount>50);
+end;
+
+
+function _fatalerror(w : tmsgconst) : boolean;
+begin
+  ShowExtError(V_Error,w);
+  _fatalerror:=true;
+end;
+
+{$endif}
+
+begin
+{$ifdef FPC}
+  do_stop:=@_stop;
+  do_comment:=@_comment;
+  {$ifdef allow_oldstyle}
+     do_note:=@_note;
+     do_warning:=@_warning;
+     do_error:=@_error;
+     do_fatalerror:=@_fatalerror;
+     do_internalerror:=@_internalerror;
+  {$endif}
+{$else}
+  do_stop:=_stop;
+  do_comment:=_comment;
+  {$ifdef allow_oldstyle}
+     do_note:=_note;
+     do_warning:=_warning;
+     do_error:=_error;
+     do_fatalerror:=_fatalerror;
+     do_internalerror:=_internalerror;
+  {$endif}
+{$endif}
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.6  1998/03/10 16:43:34  peter
+    * fixed Fatal error writting
+
+  Revision 1.5  1998/03/10 01:17:30  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.4  1998/03/06 00:53:02  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.3  1998/03/04 17:34:15  michael
+  + Changed ifdef FPK to ifdef FPC
+
+  Revision 1.2  1998/03/03 16:45:25  peter
+    + message support for assembler parsers
+
+}

compiler/verbose.pas

@@ -0,0 +1,326 @@
+{
+    $Id$
+    Copyright (c) 1998 by the FPC development team
+
+    This unit handles the verbose management
+
+    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 verbose;
+interface
+
+uses messages;
+
+{$define allow_oldstyle}
+
+{$IFNDEF EXTERN_MSG}
+  {$i msgtxt.inc}
+{$ENDIF}
+
+{$i msgidx.inc}
+
+Const
+  MaxErrorCount = 50;
+{ <$100 can include file and linenr info }
+  V_Fatal       = $0;
+  V_Error       = $1;
+  V_Warning     = $2;
+  V_Note        = $4;
+  V_Hint        = $8;
+  V_Info        = $100;
+  V_Linenrs     = $200;
+  V_Used        = $400;
+  V_Tried       = $800;
+  V_Macro       = $1000;
+  V_Procedure   = $2000;
+  V_Conditional = $4000;
+  V_Debug       = $8000;
+
+  V_All         = $ffffffff;
+  V_Default     = V_Error;
+
+  Verbosity     : longint=V_Default;
+
+var
+  errorcount    : longint;  { number of generated errors }
+  msg           : pmessage;
+
+procedure LoadMsgFile(const fn:string);
+function  SetVerbosity(const s:string):boolean;
+
+procedure stop;
+procedure comment(l:longint;const s:string);
+procedure internalerror(i:longint);
+procedure Message(w:tmsgconst);
+procedure Message1(w:tmsgconst;const s1:string);
+procedure Message2(w:tmsgconst;const s1,s2:string);
+procedure Message3(w:tmsgconst;const s1,s2,s3:string);
+
+{ old calling style }
+{$ifdef allow_oldstyle}
+var
+  exterror      : pchar;
+procedure note(w:tmsgconst);
+procedure warning(w:tmsgconst);
+procedure error(w:tmsgconst);
+procedure fatalerror(w:tmsgconst);
+{$endif}
+
+{ Function redirecting for IDE support }
+type
+  tstopprocedure = procedure;
+  tcommentprocedure = procedure(Level:Longint;const s:string);
+{old handlers }
+  terrorfunction = function(w:tmsgconst) : boolean;
+  tinternalerrorfunction = function(i : longint) : boolean;
+var
+{ this procedure is called to stop the compiler                 }
+{ e.g. this procedure has to restore the state before compiling }
+  do_stop : tstopprocedure;
+
+{ called when writing something to the screen, called with the level }
+{ of the comment }
+  do_comment : tcommentprocedure;
+
+{ only for compatibility }
+  do_note,do_warning,do_error,do_fatalerror : terrorfunction;
+  do_internalerror : tinternalerrorfunction;
+
+
+implementation
+uses globals;
+
+
+procedure LoadMsgFile(const fn:string);
+begin
+  if not (msg=nil) then
+   dispose(msg,Done);
+  msg:=new(pmessage,InitExtern(fn,ord(endmsgconst)));
+end;
+
+
+function SetVerbosity(const s:string):boolean;
+var
+  m : Longint;
+  c : Word;
+begin
+  setverbosity:=false;
+  val(s,m,c);
+  if (c=0) and (s<>'') then
+   verbosity:=m
+  else
+   begin
+     for c:=1 to length(s) do
+      case upcase(s[c]) of
+      { Special cases }
+       'A' : Verbosity:=V_All;
+       '0' : Verbosity:=V_Default;
+      { Normal cases - do an or }
+       'E' : Verbosity:=Verbosity or V_Error;
+       'I' : Verbosity:=Verbosity or V_Info;
+       'W' : Verbosity:=Verbosity or V_Warning;
+       'N' : Verbosity:=Verbosity or V_Note;
+       'H' : Verbosity:=Verbosity or V_Hint;
+       'L' : Verbosity:=Verbosity or V_Linenrs;
+       'U' : Verbosity:=Verbosity or V_Used;
+       'T' : Verbosity:=Verbosity or V_Tried;
+       'M' : Verbosity:=Verbosity or V_Macro;
+       'P' : Verbosity:=Verbosity or V_Procedure;
+       'C' : Verbosity:=Verbosity or V_Conditional;
+       'D' : Verbosity:=Verbosity or V_Debug;
+      end;
+   end;
+  setverbosity:=true;
+end;
+
+
+
+procedure stop;
+begin
+{$ifndef TP}
+  do_stop();
+{$else}
+  do_stop;
+{$endif}
+end;
+
+
+procedure internalerror(i : longint);
+begin
+  do_internalerror(i);
+  stop;
+end;
+
+
+procedure Comment(l:longint;const s:string);
+begin
+  do_comment(l,s);
+end;
+
+
+Procedure Msg2Comment(s:string);
+var
+  idx,i,v : longint;
+  dostop  : boolean;
+begin
+{Reset}
+  dostop:=false;
+  v:=0;
+{Parse options}
+  idx:=pos('_',s);
+  if idx=0 then
+   v:=V_Default
+  else
+   if (idx in [1..5]) then
+    begin
+      for i:=1to idx do
+       begin
+         case upcase(s[i]) of
+          'F' : begin
+                  v:=v or V_Fatal;
+                  dostop:=true;
+                end;
+          'E' : begin
+                  v:=v or V_Error;
+                  inc(errorcount);
+                  dostop:=(errorcount>maxerrorcount);
+                end;
+          'W' : v:=v or V_Warning;
+          'N' : v:=v or V_Note;
+          'H' : v:=v or V_Hint;
+          'I' : v:=v or V_Info;
+          'L' : v:=v or V_Linenrs;
+          'U' : v:=v or V_Used;
+          'T' : v:=v or V_Tried;
+          'M' : v:=v or V_Macro;
+          'P' : v:=v or V_Procedure;
+          'C' : v:=v or V_Conditional;
+          'D' : v:=v or V_Debug;
+          'S' : dostop:=true;
+          '_' : ;
+         end;
+       end;
+    end;
+  Delete(s,1,idx);
+  Comment(v,s);
+  if dostop then
+   stop;
+end;
+
+
+procedure Message(w:tmsgconst);
+begin
+  Msg2Comment(msg^.Get(ord(w)));
+end;
+
+
+procedure Message1(w:tmsgconst;const s1:string);
+begin
+  Msg2Comment(msg^.Get1(ord(w),s1));
+end;
+
+
+procedure Message2(w:tmsgconst;const s1,s2:string);
+begin
+  Msg2Comment(msg^.Get2(ord(w),s1,s2));
+end;
+
+
+procedure Message3(w:tmsgconst;const s1,s2,s3:string);
+begin
+  Msg2Comment(msg^.Get3(ord(w),s1,s2,s3));
+end;
+
+
+{*****************************************************************************
+                                   Old Style
+*****************************************************************************}
+
+{$ifdef allow_oldstyle}
+
+  procedure warning(w:tmsgconst);
+  begin
+    if do_warning(w) then
+     stop;
+  end;
+
+
+  procedure note(w:tmsgconst);
+  begin
+    if do_note(w) then
+     stop;
+  end;
+
+
+  procedure error(w:tmsgconst);
+  begin
+    inc(errorcount);
+    if do_error(w) then
+     stop;
+  end;
+
+
+  procedure fatalerror(w:tmsgconst);
+  begin
+    do_fatalerror(w);
+    stop;
+  end;
+
+{$endif}
+
+begin
+{$IFNDEF EXTERN_MSG}
+  msg:=new(pmessage,Init(@msgtxt,ord(endmsgconst)));
+{$ENDIF}
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.17  1998/03/10 16:43:34  peter
+    * fixed Fatal error writting
+
+  Revision 1.16  1998/03/10 01:17:30  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.15  1998/03/06 00:53:02  peter
+    * replaced all old messages from errore.msg, only ExtDebug and some
+      Comment() calls are left
+    * fixed options.pas
+
+  Revision 1.14  1998/03/04 01:35:15  peter
+    * messages for unit-handling and assembler/linker
+    * the compiler compiles without -dGDB, but doesn't work yet
+    + -vh for Hint
+
+  Revision 1.13  1998/03/03 16:45:25  peter
+    + message support for assembler parsers
+
+  Revision 1.12  1998/03/02 16:02:05  peter
+    * new style messages for pp.pas
+    * cleanup of pp.pas
+
+  Revision 1.11  1998/03/02 01:49:40  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
+
+}

compiler/version.inc

@@ -0,0 +1,150 @@
+{------------------------------------------------------------------------------
+               Define VER_ABOVE_xx For easier Version support
+
+------------------------------------------------------------------------------}
+
+{$IFDEF VER0_99_0}
+  {$DEFINE VER_ABOVE0_99_0}
+{$ENDIF VER0_99_0}
+
+{$IFDEF VER0_99}
+  {$DEFINE VER_ABOVE0_99}
+{$ENDIF VER0_99}
+
+{$IFDEF VER0_9_8}
+  {$DEFINE VER_ABOVE0_9_8}
+{$ENDIF VER0_9_8}
+
+{$IFDEF VER0_9_7}
+  {$DEFINE VER_ABOVE0_9_7}
+{$ENDIF VER0_9_7}
+
+{$IFDEF VER0_9_6}
+  {$DEFINE VER_ABOVE0_9_6}
+{$ENDIF VER0_9_6}
+
+{$IFDEF VER0_9_5}
+  {$DEFINE VER_ABOVE0_9_5}
+{$ENDIF VER0_9_5}
+
+{$IFDEF VER0_9_4}
+  {$DEFINE VER_ABOVE0_9_4}
+{$ENDIF VER0_9_4}
+
+{$IFDEF VER0_9_3}
+  {$DEFINE VER_ABOVE0_9_3}
+{$ENDIF VER0_9_3}
+
+{$IFDEF VER0_9_2}
+  {$DEFINE VER_ABOVE0_9_2}
+{$ENDIF VER0_9_2}
+
+{$IFDEF VER0_9_1}
+  {$DEFINE VER_ABOVE0_9_1}
+{$ENDIF VER0_9_1}
+
+{$IFDEF VER0_9}
+  {$DEFINE VER_ABOVE0_9}
+{$ENDIF VER0_9}
+
+{$IFDEF VER0_6_6}
+  {$DEFINE VER_ABOVE0_6_6}
+{$ENDIF VER0_6_6}
+
+{$IFDEF VER0_6_5}
+  {$DEFINE VER_ABOVE0_6_5}
+{$ENDIF VER0_6_5}
+
+{$IFDEF VER0_6_4}
+  {$DEFINE VER_ABOVE0_6_4}
+{$ENDIF VER0_6_4}
+
+{$IFDEF VER0_6_3}
+  {$DEFINE VER_ABOVE0_6_3}
+{$ENDIF VER0_6_3}
+
+{$IFDEF VER0_6_2}
+  {$DEFINE VER_ABOVE0_6_2}
+{$ENDIF VER0_6_2}
+
+{$IFDEF VER0_6_1}
+  {$DEFINE VER_ABOVE0_6_1}
+{$ENDIF VER0_6_1}
+
+{$IFDEF VER0_6}
+  {$DEFINE VER_ABOVE0_6}
+{$ENDIF VER0_6}
+
+{------------------------------------------------------------------------------
+       Higher versions always include lower versions, so define them also
+
+------------------------------------------------------------------------------}
+
+{$IFDEF VER_ABOVE0_99_0}
+  {$DEFINE VER_ABOVE0_99}
+{$ENDIF VER_ABOVE0_99_0}
+
+{$IFDEF VER_ABOVE0_99}
+  {$DEFINE VER_ABOVE0_9_8}
+{$ENDIF VER_ABOVE0_99}
+
+{$IFDEF VER_ABOVE0_9_8}
+  {$DEFINE VER_ABOVE0_9_7}
+{$ENDIF VER_ABOVE0_9_8}
+
+{$IFDEF VER_ABOVE0_9_7}
+  {$DEFINE VER_ABOVE0_9_6}
+{$ENDIF VER_ABOVE0_9_7}
+
+{$IFDEF VER_ABOVE0_9_6}
+  {$DEFINE VER_ABOVE0_9_5}
+{$ENDIF VER_ABOVE0_9_6}
+
+{$IFDEF VER_ABOVE0_9_5}
+  {$DEFINE VER_ABOVE0_9_4}
+{$ENDIF VER_ABOVE0_9_5}
+
+{$IFDEF VER_ABOVE0_9_4}
+  {$DEFINE VER_ABOVE0_9_3}
+{$ENDIF VER_ABOVE0_9_4}
+
+{$IFDEF VER_ABOVE0_9_3}
+  {$DEFINE VER_ABOVE0_9_2}
+{$ENDIF VER_ABOVE0_9_3}
+
+{$IFDEF VER_ABOVE0_9_2}
+  {$DEFINE VER_ABOVE0_9_1}
+{$ENDIF VER_ABOVE0_9_2}
+
+{$IFDEF VER_ABOVE0_9_1}
+  {$DEFINE VER_ABOVE0_9}
+{$ENDIF VER_ABOVE0_9_1}
+
+{$IFDEF VER_ABOVE0_9}
+  {$DEFINE VER_ABOVE0_6_6}
+{$ENDIF VER_ABOVE0_9}
+
+{$IFDEF VER_ABOVE0_6_6}
+  {$DEFINE VER_ABOVE0_6_5}
+{$ENDIF VER_ABOVE0_6_6}
+
+{$IFDEF VER_ABOVE0_6_5}
+  {$DEFINE VER_ABOVE0_6_4}
+{$ENDIF VER_ABOVE0_6_5}
+
+{$IFDEF VER_ABOVE0_6_4}
+  {$DEFINE VER_ABOVE0_6_3}
+{$ENDIF VER_ABOVE0_6_4}
+
+{$IFDEF VER_ABOVE0_6_3}
+  {$DEFINE VER_ABOVE0_6_2}
+{$ENDIF VER_ABOVE0_6_3}
+
+{$IFDEF VER_ABOVE0_6_2}
+  {$DEFINE VER_ABOVE0_6_1}
+{$ENDIF VER_ABOVE0_6_2}
+
+{$IFDEF VER_ABOVE0_6_1}
+  {$DEFINE VER_ABOVE0_6}
+{$ENDIF VER_ABOVE0_6_1}
+

compiler/win_targ.pas

@@ -0,0 +1,206 @@
+{
+    $Id$
+    Copyright (c) 1998 by Florian Klaempfl
+
+    This unit implements some support routines for the win32 target like
+    import/export handling
+
+    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 win_targ;
+
+  interface
+
+  uses import;
+
+  type
+    pimportlibwin32=^timportlibwin32;
+    timportlibwin32=object(timportlib)
+      procedure preparelib(const s:string);virtual;
+      procedure importprocedure(const func,module:string;index:longint;const name:string);virtual;
+      procedure generatelib;virtual;
+    end;
+
+  implementation
+
+    uses
+       aasm,files,strings,globals,cobjects
+{$ifdef i386}
+       ,i386
+{$endif}
+{$ifdef m68k}
+       ,m68k
+{$endif}
+       ;
+
+    procedure timportlibwin32.preparelib(const s : string);
+
+      begin
+         if not(assigned(importssection)) then
+           importssection:=new(paasmoutput,init);
+      end;
+
+    procedure timportlibwin32.importprocedure(const func,module : string;index : longint;const name : string);
+
+      var
+         hp1 : pimportlist;
+         hp2 : pimported_procedure;
+
+      begin
+         { search for the module }
+         hp1:=pimportlist(current_module^.imports^.first);
+         while assigned(hp1) do
+           begin
+              if module=hp1^.dllname^ then
+                break;
+              hp1:=pimportlist(hp1^.next);
+           end;
+         { generate a new item ? }
+         if not(assigned(hp1)) then
+           begin
+              hp1:=new(pimportlist,init(module));
+              current_module^.imports^.concat(hp1);
+           end;
+         hp2:=new(pimported_procedure,init(func,name,index));
+         hp1^.imported_procedures^.concat(hp2);
+      end;
+
+    procedure timportlibwin32.generatelib;
+
+      var
+         hp1 : pimportlist;
+         hp2 : pimported_procedure;
+         l1,l2,l3,l4 : plabel;
+         r : preference;
+
+      begin
+         hp1:=pimportlist(current_module^.imports^.first);
+         while assigned(hp1) do
+           begin
+              getlabel(l1);
+              getlabel(l2);
+              getlabel(l3);
+              { create import directory entry }
+              importssection^.concat(new(pai_section,init('.idata$2')));
+              { pointer to procedure names }
+              importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
+                (l2)))));
+              { two empty entries follow }
+              importssection^.concat(new(pai_const,init_32bit(0)));
+              importssection^.concat(new(pai_const,init_32bit(0)));
+              { pointer to dll name }
+              importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
+                (l1)))));
+              { pointer to fixups }
+              importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
+                (l3)))));
+
+              { now walk through all imported procedures }
+              { we could that do in one while loop, but  }
+              { this would give too much idata* entries  }
+
+              { first write the name references }
+              importssection^.concat(new(pai_section,init('.idata$4')));
+              importssection^.concat(new(pai_label,init(l2)));
+              hp2:=pimported_procedure(hp1^.imported_procedures^.first);
+              while assigned(hp2) do
+                begin
+                   getlabel(plabel(hp2^.lab));
+                   importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
+                     (hp2^.lab)))));
+                   hp2:=pimported_procedure(hp2^.next);
+                end;
+              { finalize the names ... }
+              importssection^.concat(new(pai_const,init_32bit(0)));
+
+              { then the addresses and create also the indirect jump }
+              importssection^.concat(new(pai_section,init('.idata$5')));
+              importssection^.concat(new(pai_label,init(l3)));
+              hp2:=pimported_procedure(hp1^.imported_procedures^.first);
+              while assigned(hp2) do
+                begin
+                   getlabel(l4);
+                   { text segment should be aligned }
+                   codesegment^.concat(new(pai_align,init_op(4,$90)));
+                   codesegment^.concat(new(pai_symbol,init_global(hp2^.func^)));
+                   { the indirect jump }
+                   new(r);
+                   reset_reference(r^);
+                   r^.symbol:=stringdup(lab2str(l4));
+{$ifdef i386}
+                   codesegment^.concat(new(pai386,op_ref(A_JMP,S_NO,r)));
+{$endif}
+                   importssection^.concat(new(pai_label,init(l4)));
+                   importssection^.concat(new(pai_const,init_rva(strpnew(lab2str
+                      (hp2^.lab)))));
+                   hp2:=pimported_procedure(hp2^.next);
+                end;
+              { finalize the addresses }
+              importssection^.concat(new(pai_const,init_32bit(0)));
+
+              { finally the import information }
+              importssection^.concat(new(pai_section,init('.idata$6')));
+              hp2:=pimported_procedure(hp1^.imported_procedures^.first);
+              while assigned(hp2) do
+                begin
+                   importssection^.concat(new(pai_label,init(hp2^.lab)));
+                   { the ordinal number }
+                   importssection^.concat(new(pai_const,init_16bit(hp2^.ordnr)));
+                   importssection^.concat(new(pai_string,init(hp2^.name^+#0)));
+                   hp2:=pimported_procedure(hp2^.next);
+                end;
+              { create import dll name }
+              importssection^.concat(new(pai_section,init('.idata$7')));
+              importssection^.concat(new(pai_label,init(l1)));
+              importssection^.concat(new(pai_string,init(hp1^.dllname^+#0)));
+
+              hp1:=pimportlist(hp1^.next);
+           end;
+      end;
+
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:15  root
+  Initial revision
+
+  Revision 1.9  1998/03/10 13:23:00  florian
+    * small win32 problems fixed
+
+  Revision 1.8  1998/03/10 01:17:31  peter
+    * all files have the same header
+    * messages are fully implemented, EXTDEBUG uses Comment()
+    + AG... files for the Assembler generation
+
+  Revision 1.7  1998/03/04 10:35:34  florian
+    * writing of externals fixed
+
+  Revision 1.6  1998/03/02 13:38:52  peter
+    + importlib object
+    * doesn't crash on a systemunit anymore
+    * updated makefile and depend
+
+  Revision 1.4  1998/02/28 14:43:50  florian
+    * final implemenation of win32 imports
+    * extended tai_align to allow 8 and 16 byte aligns
+
+  Revision 1.3  1998/02/28 09:30:59  florian
+    + writing of win32 import section added
+
+  Revision 1.2  1998/02/28 00:20:35  florian
+    * more changes to get import libs for Win32 working
+}

rtl/COPYING

@@ -0,0 +1,340 @@
+
+		    GNU GENERAL PUBLIC LICENSE
+		       Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+                          675 Mass Ave, Cambridge, MA 02139, USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+			    Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users.  This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it.  (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.)  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+  To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have.  You must make sure that they, too, receive or can get the
+source code.  And you must show them these terms so they know their
+rights.
+
+  We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+  Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software.  If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+  Finally, any free program is threatened constantly by software
+patents.  We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary.  To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+		    GNU GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License.  The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language.  (Hereinafter, translation is included without limitation in
+the term "modification".)  Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+  1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+  2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) You must cause the modified files to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    b) You must cause any work that you distribute or publish, that in
+    whole or in part contains or is derived from the Program or any
+    part thereof, to be licensed as a whole at no charge to all third
+    parties under the terms of this License.
+
+    c) If the modified program normally reads commands interactively
+    when run, you must cause it, when started running for such
+    interactive use in the most ordinary way, to print or display an
+    announcement including an appropriate copyright notice and a
+    notice that there is no warranty (or else, saying that you provide
+    a warranty) and that users may redistribute the program under
+    these conditions, and telling the user how to view a copy of this
+    License.  (Exception: if the Program itself is interactive but
+    does not normally print such an announcement, your work based on
+    the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+    a) Accompany it with the complete corresponding machine-readable
+    source code, which must be distributed under the terms of Sections
+    1 and 2 above on a medium customarily used for software interchange; or,
+
+    b) Accompany it with a written offer, valid for at least three
+    years, to give any third party, for a charge no more than your
+    cost of physically performing source distribution, a complete
+    machine-readable copy of the corresponding source code, to be
+    distributed under the terms of Sections 1 and 2 above on a medium
+    customarily used for software interchange; or,
+
+    c) Accompany it with the information you received as to the offer
+    to distribute corresponding source code.  (This alternative is
+    allowed only for noncommercial distribution and only if you
+    received the program in object code or executable form with such
+    an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it.  For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable.  However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License.  Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+  5. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Program or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+  6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+  7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation.  If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+  10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission.  For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this.  Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+			    NO WARRANTY
+
+  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+		     END OF TERMS AND CONDITIONS
+
+	Appendix: How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) 19yy  <name of author>
+
+    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.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+    Gnomovision version 69, Copyright (C) 19yy name of author
+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+  `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+  <signature of Ty Coon>, 1 April 1989
+  Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs.  If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library.  If this is what you want to do, use the GNU Library General
+Public License instead of this License.

rtl/COPYING.FPC

@@ -0,0 +1,20 @@
+This is the file COPYING.FPC, it applies to the Free Pascal Run-Time Library 
+source files copyrighted by members of the Free Pascal Development Team.
+
+The source code of Free Pascal is distributed under the GNU General
+Public License (see the file COPYING) with the following exceptions:
+
+- object files and libraries linked into an application may be
+  distributed without source code
+
+If you didn't receive a copy of the file COPYING, contact: 
+      Free Software Foundation
+      675 Mass Ave
+      Cambridge, MA  02139
+      USA
+
+
+Suggestions, ideas ?? Please correct spelling mistakes in the license,
+if you see one.
+
+

rtl/amiga/crt.pp

@@ -0,0 +1,627 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1997 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+
+
+unit Crt;
+
+INTERFACE
+
+    const
+       { screen modes }
+       bw40 = 0;
+       co40 = 1;
+       bw80 = 2;
+       co80 = 3;
+       mono = 7;
+       font8x8 = 256;
+
+       { screen color, fore- and background }
+       black = 0;
+       blue = 1;
+       green = 2;
+       cyan = 3;
+       red = 4;
+       magenta = 5;
+       brown = 6;
+       lightgray = 7;
+
+       { only foreground }
+       darkgray = 8;
+       lightblue = 9;
+       lightgreen = 10;
+       lightcyan = 11;
+       lightred = 12;
+       lightmagenta = 13;
+       yellow = 14;
+       white = 15;
+
+       { blink flag }
+       blink = $80;
+
+    var
+       { for compatibility }
+       checkbreak,checkeof,checksnow : boolean;
+
+       { works in another way than in TP }
+       { true: cursor is set with direct port access }
+       { false: cursor is set with a bios call       }
+       directvideo : boolean;
+
+       lastmode : word; { screen mode}
+       textattr : byte; { current text attribute }
+       windmin : word; { upper right corner of the CRT window }
+       windmax : word; { lower left corner of the CRT window }
+
+    function keypressed : boolean;
+    function readkey : char;
+    procedure gotoxy(x,y : integer);
+    procedure window(left,top,right,bottom : byte);
+    procedure clrscr;
+    procedure textcolor(color : byte);
+    procedure textbackground(color : byte);
+    procedure assigncrt(var f : text);
+    function wherex : integer;
+    function wherey : integer;
+    procedure delline;
+    procedure delline(line : byte);
+    procedure clreol;
+    procedure insline;
+    procedure cursoron;
+    procedure cursoroff;
+    procedure cursorbig;
+    procedure lowvideo;
+    procedure highvideo;
+    procedure nosound;
+    procedure sound(hz : word);
+    procedure delay(ms : longint);
+    procedure textmode(mode : integer);
+    procedure normvideo;
+
+  implementation
+
+Type
+
+{$PACKRECORDS 4}
+{ returned by Info(), must be on a 4 byte boundary }
+
+    pInfoData = ^tInfoData;
+    tInfoData = record
+        id_NumSoftErrors        : Longint;      { number of soft errors on disk }
+        id_UnitNumber           : Longint;      { Which unit disk is (was) mounted on }
+        id_DiskState            : Longint;      { See defines below }
+        id_NumBlocks            : Longint;      { Number of blocks on disk }
+        id_NumBlocksUsed        : Longint;      { Number of block in use }
+        id_BytesPerBlock        : Longint;
+        id_DiskType             : Longint;      { Disk Type code }
+        id_VolumeNode           : Longint;         { BCPL pointer to volume node }
+        id_InUse                : Longint;      { Flag, zero if not in use }
+    end;
+
+{ *  List Node Structure.  Each member in a list starts with a Node * }
+
+  pNode = ^tNode;
+  tNode = Record
+    ln_Succ,                { * Pointer to next (successor) * }
+    ln_Pred  : pNode;       { * Pointer to previous (predecessor) * }
+    ln_Type  : Byte;
+    ln_Pri   : Shortint;    { * Priority, for sorting * }
+    ln_Name  : PChar;       { * ID string, null terminated * }
+  End;  { * Note: Integer aligned * }
+
+{$PACKRECORDS NORMAL}
+
+{ normal, full featured list }
+
+    pList = ^tList;
+    tList = record
+    lh_Head     : pNode;
+    lh_Tail     : pNode;
+    lh_TailPred : pNode;
+    lh_Type     : Byte;
+    l_pad       : Byte;
+    end;
+
+    pMsgPort = ^tMsgPort;
+    tMsgPort = record
+    mp_Node     : tNode;
+    mp_Flags    : Byte;
+    mp_SigBit   : Byte;      { signal bit number    }
+    mp_SigTask  : Pointer;   { task to be signalled (TaskPtr) }
+    mp_MsgList  : tList;     { message linked list  }
+    end;
+
+    pMessage = ^tMessage;
+    tMessage = record
+    mn_Node       : tNode;
+    mn_ReplyPort  : pMsgPort;   { message reply port }
+    mn_Length     : Word;       { message len in bytes }
+    end;
+
+    pIOStdReq = ^tIOStdReq;
+    tIOStdReq = record
+    io_Message  : tMessage;
+    io_Device   : Pointer;      { device node pointer  }
+    io_Unit     : Pointer;      { unit (driver private)}
+    io_Command  : Word;         { device command }
+    io_Flags    : Byte;
+    io_Error    : Shortint;     { error or warning num }
+    io_Actual   : Longint;      { actual number of bytes transferred }
+    io_Length   : Longint;      { requested number bytes transferred}
+    io_Data     : Pointer;      { points to data area }
+    io_Offset   : Longint;      { offset for block structured devices }
+    end;
+                                    
+    pIntuiMessage = ^tIntuiMessage;
+    tIntuiMessage = record
+        ExecMessage     : tMessage;
+        Class_          : Longint;
+        Code            : Word;
+        Qualifier       : Word;
+        IAddress        : Pointer;
+        MouseX,
+        MouseY          : Word;
+        Seconds,
+        Micros          : Longint;
+        IDCMPWindow     : Pointer;
+        SpecialLink     : pIntuiMessage;
+    end;
+
+    pWindow = ^tWindow;
+    tWindow = record
+        NextWindow      : pWindow;      { for the linked list in a screen }
+        LeftEdge,
+        TopEdge         : Integer;      { screen dimensions of window }
+        Width,
+        Height          : Integer;      { screen dimensions of window }
+        MouseY,
+        MouseX          : Integer;      { relative to upper-left of window }
+        MinWidth,
+        MinHeight       : Integer;      { minimum sizes }
+        MaxWidth,
+        MaxHeight       : Word;         { maximum sizes }
+        Flags           : Longint;      { see below for defines }
+        MenuStrip       : Pointer;      { the strip of Menu headers }
+        Title           : PChar;        { the title text for this window }
+        FirstRequest    : Pointer;      { all active Requesters }
+        DMRequest       : Pointer;      { double-click Requester }
+        ReqCount        : Integer;      { count of reqs blocking Window }
+        WScreen         : Pointer;      { this Window's Screen }
+        RPort           : Pointer;      { this Window's very own RastPort }
+        BorderLeft,
+        BorderTop,
+        BorderRight,
+        BorderBottom    : Shortint;
+        BorderRPort     : Pointer;
+        FirstGadget     : Pointer;
+        Parent,
+        Descendant      : pWindow;
+        Pointer_        : Pointer;      { sprite data }
+        PtrHeight       : Shortint;     { sprite height (not including sprite padding) }
+        PtrWidth        : Shortint;     { sprite width (must be less than or equal to 16) }
+        XOffset,
+        YOffset         : Shortint;     { sprite offsets }
+        IDCMPFlags      : Longint;      { User-selected flags }
+        UserPort,
+        WindowPort      : pMsgPort;
+        MessageKey      : pIntuiMessage;
+        DetailPen,
+        BlockPen        : Byte;         { for bar/border/gadget rendering }
+        CheckMark       : Pointer;
+        ScreenTitle     : PChar;        { if non-null, Screen title when Window is active }
+        GZZMouseX       : Integer;
+        GZZMouseY       : Integer;
+        GZZWidth        : Integer;
+        GZZHeight       : Word;
+        ExtData         : Pointer;
+        UserData        : Pointer;      { general-purpose pointer to User data extension }
+        WLayer          : Pointer;
+        IFont           : Pointer;
+        MoreFlags       : Longint;
+    end;
+                                                    
+              
+    pConUnit = ^tConUnit;
+    tConUnit = record
+        cu_MP   : tMsgPort;
+        cu_Window       : Pointer;      { (WindowPtr) intuition window bound to this unit }
+        cu_XCP          : Integer;      { character position }
+        cu_YCP          : Integer;
+        cu_XMax         : Integer;      { max character position }
+        cu_YMax         : Integer;
+        cu_XRSize       : Integer;      { character raster size }
+        cu_YRSize       : Integer;
+        cu_XROrigin     : Integer;      { raster origin }
+        cu_YROrigin     : Integer;
+        cu_XRExtant     : Integer;      { raster maxima }
+        cu_YRExtant     : Integer;
+        cu_XMinShrink   : Integer;      { smallest area intact from resize process }
+        cu_YMinShrink   : Integer;
+        cu_XCCP         : Integer;      { cursor position }
+        cu_YCCP         : Integer;
+        cu_KeyMapStruct : Pointer;
+        cu_TabStops     : Array [0..80-1] of Word;
+        cu_Mask         : Shortint;
+        cu_FgPen        : Shortint;
+        cu_BgPen        : Shortint;
+        cu_AOLPen       : Shortint;
+        cu_DrawMode     : Shortint;
+        cu_AreaPtSz     : Shortint;
+        cu_AreaPtrn     : Pointer;      { cursor area pattern }
+        cu_Minterms     : Array [0..7] of Byte; { console minterms }
+        cu_Font         : Pointer;      { (TextFontPtr) }
+        cu_AlgoStyle    : Byte;
+        cu_TxFlags      : Byte;
+        cu_TxHeight     : Word;
+        cu_TxWidth      : Word;
+        cu_TxBaseline   : Word;
+        cu_TxSpacing    : Word;
+        cu_Modes        : Array [0..(22+7) div 8 - 1] of Byte;
+        cu_RawEvents    : Array [0..($15+7) div 8 - 1] of Byte;
+    end;
+                                                           
+const
+   
+   
+   CD_CURRX =  1;
+   CD_CURRY =  2;
+   CD_MAXX  =  3;
+   CD_MAXY  =  4;
+
+
+function AllocVec( size, reqm : Longint ): Pointer; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  size,d0
+    MOVE.L  reqm,d1
+    JSR -684(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function DoPkt(ID : pMsgPort;
+               Action, Param1, Param2,
+               Param3, Param4, Param5 : Longint) : Longint; Assembler;
+asm
+    MOVEM.L d2/d3/d4/d5/d6/d7/a6,-(A7)
+    MOVE.L  _DOSBase,A6
+    MOVE.L  ID,d1
+    MOVE.L  Action,d2
+    MOVE.L  Param1,d3
+    MOVE.L  Param2,d4
+    MOVE.L  Param3,d5
+    MOVE.L  Param4,d6
+    MOVE.L  Param5,d7
+    JSR -240(A6)
+    MOVEM.L (A7)+,d2/d3/d4/d5/d6/d7/a6
+end;
+
+procedure FreeVec( memory : Pointer ); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  memory,a1
+    JSR -690(A6)
+    MOVE.L  (A7)+,A6
+end;
+                                      
+
+function GetConsoleTask : pMsgPort; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _DOSBase,A6
+    JSR -510(A6)
+    MOVE.L  (A7)+,A6
+end;
+                            
+
+function GetMsg(port : pMsgPort): pMessage; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  port,a0
+    JSR -372(A6)
+    MOVE.L  (A7)+,A6
+end;
+                                
+function ModifyIDCMP(window : pWindow;
+                     IDCMPFlags : Longint) : Boolean; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _IntuitionBase,A6
+    MOVE.L  window,a0
+    MOVE.L  IDCMPFlags,d0
+    JSR -150(A6)
+    MOVE.L  (A7)+,A6
+    TST.L   d0
+    SNE     d0
+end;
+                                                    
+procedure ReplyMsg(mess : pMessage); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  mess,a1
+    JSR -378(A6)
+    MOVE.L  (A7)+,A6
+end;
+                               
+
+function WaitPort(port : pMsgPort): pMessage; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  port,a0
+    JSR -384(A6)
+    MOVE.L  (A7)+,A6
+end;
+                        
+procedure Delay_(ticks : Integer); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _DOSBase,A6
+    MOVE.L  ticks,d1
+    JSR -198(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+   
+function OpenInfo : pInfoData;
+var
+   port     :  pMsgPort;
+   info     :  pInfoData;
+   bptr, d4, d5, d6, d7 :  Longint;
+begin
+   info  := pInfoData(AllocVec(SizeOf(tInfoData), 1));
+   
+   if info <> nil then begin
+      port  := GetConsoleTask;
+      bptr  := Longint(info) shr 2;
+      
+      if port <> nil then begin
+         if DoPkt(port, $19, bptr, d4, d5, d6, d7) <> 0 then info := pInfoData(bptr shl 2)
+         else port := nil;
+      end;
+      
+      if port = nil then begin   
+         FreeVec(info);
+         info := nil;
+      end;
+   end;
+
+   OpenInfo := info;
+end;
+
+procedure CloseInfo(var info : pInfoData);
+begin
+   if info <> nil then begin
+      FreeVec(info);
+      info := nil;
+   end;
+end;
+
+function ConData(modus : byte) : integer;
+var
+   info  :  pInfoData;
+   theunit  :  pConUnit;
+   pos   :  Longint;
+begin
+   pos   := 1;
+   info  := OpenInfo;
+   
+   if info <> nil then begin
+      theunit  := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit);
+
+      case modus of
+         CD_CURRX :  pos   := theunit^.cu_XCP;
+         CD_CURRY :  pos   := theunit^.cu_YCP;
+         CD_MAXX  :  pos   := theunit^.cu_XMax;
+         CD_MAXY  :  pos   := theunit^.cu_YMax;
+      end;
+      
+      CloseInfo(info);
+   end;
+   
+   ConData := pos + 1;
+end;
+
+function wherex : integer;
+begin
+   wherex := ConData(CD_CURRX);
+end;
+
+function wherey : integer;
+begin
+   wherey := ConData(CD_CURRY);
+end;
+
+function maxx : integer;
+begin
+   maxx := ConData(CD_MAXX);
+end;
+
+function maxy : integer;
+begin
+   maxy := ConData(CD_MAXY);
+end;
+
+procedure gotoxy(x, y : integer);
+var
+   mx, my : integer;
+begin
+   mx := maxx;
+   my := maxy;
+   
+   if x < 1 then x := wherex
+   else if x > mx then x := mx;
+   
+   if y < 1 then y := wherey
+   else if y > my then y := my;
+   
+   Write($9b, y, ';', x, 'H');
+end;
+
+procedure cursoroff;
+begin
+   Write($9b,'0 p');
+end;
+
+procedure cursoron;
+begin
+   Write($9b,'1 p');
+end;
+
+procedure clrscr;
+begin
+   Write(Chr($0c));
+end;
+
+function ReadKey : char;
+const
+   IDCMP_VANILLAKEY = $00200000;
+   IDCMP_RAWKEY     = $00000400;
+var
+   info  :  pInfoData;
+   win   :  pWindow;
+   imsg  :  pIntuiMessage;
+   msg   :  pMessage;
+   key   :  char;
+   idcmp, vanil   :  longint;
+begin
+   key   := #0;
+   info  := OpenInfo;
+
+   if info <> nil then begin
+      win   := pWindow(pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_Window);
+      idcmp := win^.IDCMPFlags;
+      vanil := IDCMP_VANILLAKEY or IDCMP_RAWKEY;
+
+      ModifyIDCMP(win, (idcmp or vanil));
+
+      repeat
+         msg   := WaitPort(win^.UserPort);
+         imsg  := pIntuiMessage(GetMsg(win^.UserPort));
+
+         if (imsg^.Class_ = IDCMP_VANILLAKEY) or (imsg^.Class_ = IDCMP_RAWKEY) then key := char(imsg^.Code);
+
+         ReplyMsg(pMessage(imsg));
+      until key <> char(0);
+
+      repeat
+         msg   := GetMsg(win^.UserPort);
+
+         if msg <> nil then ReplyMsg(msg);
+      until msg = nil;
+
+      ModifyIDCMP(win, idcmp);
+
+      CloseInfo(info);
+   end;
+
+   ReadKey := key;
+end;
+
+procedure textcolor(fgpen : byte);
+begin
+   Write($9b, '3', fgpen, 'm');
+end;
+
+procedure textbackground(bgpen : byte);
+begin
+   Write($9b, '4', bgpen, 'm');
+end;
+
+function keypressed : boolean;
+begin
+   keypressed := true;
+end;
+
+procedure window(left,top,right,bottom : byte);
+begin
+end;
+
+procedure assigncrt(var f : text);
+begin
+end;
+
+procedure delline;
+begin
+   Write($9b,'X');
+end;
+
+procedure delline(line : byte);
+begin
+   Write($9b,'X');
+end;
+
+procedure clreol;
+begin
+   Write($9b,'K');
+end;
+
+procedure insline;
+begin
+   Write($9b,'1 L');
+end;
+
+procedure cursorbig;
+begin
+end;
+
+procedure lowvideo;
+begin
+end;
+
+procedure highvideo;
+begin
+end;
+
+procedure nosound;
+begin
+end;
+
+procedure sound(hz : word);
+begin
+end;
+
+{  MsDos have 1000 ticks per second
+   and Amiga only 50, so we have to
+   do some calcs here.
+   The min value this procedure will
+   handle is 20, (less you will get 0)
+   this will be 1 tick in Amiga. If
+   you want to use amigados delay just
+   use Delay_.   }
+procedure delay(ms : longint);
+var
+    dummy : integer;
+begin
+    dummy := trunc((real(ms) / 1000.0) * 50.0);
+    Delay_(dummy);
+end;
+
+procedure textmode(mode : integer);
+begin
+end;
+
+procedure normvideo;
+begin
+end;
+
+end.
+
+
+
+
+

rtl/amiga/dos.pp

@@ -0,0 +1,729 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1998 by Nils Sjoholm
+    members of the Free Pascal development team
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+
+
+    {
+       History:
+       10.02.1998  First version for Amiga.
+                   Just GetDate and GetTime.
+
+       11.02.1998  Added AmigaToDt and DtToAmiga
+                   Changed GetDate and GetTime to
+                   use AmigaToDt and DtToAmiga.
+
+                   Added DiskSize and DiskFree.
+                   They are using a string as arg
+                   have to try to fix that.
+
+       12.02.1998  Added Fsplit and FExpand.
+                   Cleaned up the unit and removed
+                   stuff that was not used yet.
+
+       13.02.1998  Added CToPas and PasToC and removed
+                   the uses of strings.
+
+       14.02.1998  Removed AmigaToDt and DtToAmiga
+                   from public area.
+                   Added deviceids and devicenames
+                   arrays so now diskfree and disksize
+                   is compatible with dos.
+    }
+
+
+Unit Dos;
+
+
+Interface
+
+
+Type
+  ComStr  = String[255];  { size increased to be more compatible with Unix}
+  PathStr = String[255];  { size increased to be more compatible with Unix}
+  DirStr  = String[255];  { size increased to be more compatible with Unix}
+  NameStr = String[255];  { size increased to be more compatible with Unix}
+  ExtStr  = String[255];  { size increased to be more compatible with Unix}
+
+  { If you need more devicenames just expand this two arrays }
+
+  deviceids = (DF0ID, DF1ID, DF2ID, DF3ID, DH0ID, DH1ID,
+               CD0ID, MDOS1ID, MDOS2ID);
+
+       registers = record
+         case i : integer of
+            0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
+            1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
+            2 : (eax,  ebx,  ecx,  edx,  ebp,  esi,  edi : longint);
+       end;
+
+
+Const
+  devicenames : array [DF0ID..MDOS2ID] of PChar = (
+                'df0:','df1:','df2:','df3:','dh0:',
+                'dh1:','cd0','A:','B:');
+
+Type
+  SearchRec = Record
+    {Fill : array[1..21] of byte;  Fill replaced with below}
+
+    SearchNum: LongInt; {to track which search this is}
+    SearchPos: LongInt; {directory position}
+    DirPtr: LongInt; {directory pointer for reading directory}
+    SearchType: Byte;  {0=normal, 1=open will close}
+    SearchAttr: Byte; {attribute we are searching for}
+    Fill: Array[1..07] of Byte; {future use}
+    {End of replacement for fill}
+
+    Attr : Byte; {attribute of found file}
+    Time : LongInt; {last modify date of found file}
+    Size : LongInt; {file size of found file}
+    Reserved : Word; {future use}
+    Name : String[255]; {name of found file}
+    SearchSpec: String[255]; {search pattern}
+    NamePos: Word; {end of path, start of name position}
+    End;
+
+
+  FileRec = Record
+    Handle : word;
+    Mode : word;
+    RecSize : word;
+    _private : array[1..26] of byte;
+    UserData: array[1..16] of byte;
+    Name: array[0..255] of char;
+    End;
+
+
+  TextBuf = array[0..127] of char;
+
+
+  TextRec = record
+    handle : word;
+    mode : word;
+    bufSize : word;
+    _private : word;
+    bufpos : word;
+    bufend : word;
+    bufptr : ^textbuf;
+    openfunc : pointer;
+    inoutfunc : pointer;
+    flushfunc : pointer;
+    closefunc : pointer;
+    userdata : array[1..16] of byte;
+    name : array[0..255] of char;
+    buffer : textbuf;
+    End;
+
+
+  DateTime = record
+    Year: Word;
+    Month: Word;
+    Day: Word;
+    Hour: Word;
+    Min: Word;
+    Sec: word;
+    End;
+
+    pClockData = ^tClockData;
+    tClockData = Record
+      sec   : Word;
+      min   : Word;
+      hour  : Word;
+      mday  : Word;
+      month : Word;
+      year  : Word;
+      wday  : Word;
+    END;
+
+
+Procedure GetDate(var year, month, mday, wday: word);
+Procedure GetTime(var hour, minute, second, sec100: word);
+Function  DosVersion: Word;
+procedure SetDate(year,month,day: word);
+Procedure SetTime(hour,minute,second,sec100: word);
+Procedure GetCBreak(var breakvalue: boolean);
+Procedure SetCBreak(breakvalue: boolean);
+Procedure GetVerify(var verify: boolean);
+Procedure SetVerify(verify: boolean);
+Function  DiskFree(drive: byte) : longint;
+Function  DiskSize(drive: byte) : longint;
+Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
+Procedure FindNext(var f: searchRec);
+Procedure FindClose(Var f: SearchRec);
+Procedure SwapVectors;
+Procedure MSDos(var regs: registers);
+Procedure GetIntVec(intno: byte; var vector: pointer);
+Procedure SetIntVec(intno: byte; vector: pointer);
+Procedure Keep(exitcode: word);
+Procedure Intr(intno: byte; var regs: registers);
+Procedure GetFAttr(var f; var attr: word);
+Procedure SetFAttr(var f; attr: word);
+Procedure GetFTime(var f; var time: longint);
+Procedure SetFTime(var f; time: longint);
+Procedure UnpackTime(p: longint; var t: datetime);
+Procedure PackTime(var t: datetime; var p: longint);
+Function  FSearch(path: pathstr; dirlist: string): pathstr;
+Function  FExpand(const path: pathstr): pathstr;
+Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr;
+  var ext: extstr);
+Procedure Exec(const path: pathstr; const comline: comstr);
+Function  DosExitCode: word;
+Function  EnvCount: longint;
+Function  EnvStr(index: integer): string;
+Function  GetEnv (envvar: string): string;
+
+Implementation
+
+
+Type
+
+    BPTR = Longint;
+
+{$PACKRECORDS 4}
+
+{ Returned by Examine() and ExInfo(), must be on a 4 byte boundary }
+
+    pFileInfoBlock = ^tFileInfoBlock;
+    tFileInfoBlock = record
+        fib_DiskKey      : Longint;
+        fib_DirEntryType : Longint;
+                        { Type of Directory. If < 0, then a plain file.
+                          If > 0 a directory }
+        fib_FileName     : Array [0..107] of Char;
+                        { Null terminated. Max 30 chars used for now }
+        fib_Protection   : Longint;
+                        { bit mask of protection, rwxd are 3-0. }
+        fib_EntryType    : Longint;
+        fib_Size         : Longint;      { Number of bytes in file }
+        fib_NumBlocks    : Longint;      { Number of blocks in file }
+        fib_Date         : tDateStamp;   { Date file last changed }
+        fib_Comment      : Array [0..79] of Char;
+                        { Null terminated comment associated with file }
+        fib_OwnerUID     : Word;
+        fib_OwnerGID     : Word;
+        fib_Reserved     : Array [0..31] of Char;
+    end;
+
+{ returned by Info(), must be on a 4 byte boundary }
+
+    pInfoData = ^tInfoData;
+    tInfoData = record
+        id_NumSoftErrors        : Longint;      { number of soft errors on disk
+}
+        id_UnitNumber           : Longint;      { Which unit disk is (was)
+mounted on }
+        id_DiskState            : Longint;      { See defines below }
+        id_NumBlocks            : Longint;      { Number of blocks on disk }
+        id_NumBlocksUsed        : Longint;      { Number of block in use }
+        id_BytesPerBlock        : Longint;
+        id_DiskType             : Longint;      { Disk Type code }
+        id_VolumeNode           : BPTR;         { BCPL pointer to volume node }
+        id_InUse                : Longint;      { Flag, zero if not in use }
+    end;
+
+
+
+{$PACKRECORDS NORMAL}
+
+
+
+procedure CurrentTime(var Seconds, Micros : Longint); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _IntuitionBase,A6
+    MOVE.L  Seconds,a0
+    MOVE.L  Micros,a1
+    JSR -084(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+
+function Date2Amiga(date : pClockData) : Longint; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _UtilityBase,A6
+    MOVE.L  date,a0
+    JSR -126(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+
+procedure Amiga2Date(amigatime : Longint;
+                     resultat : pClockData); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _UtilityBase,A6
+    MOVE.L  amigatime,d0
+    MOVE.L  resultat,a0
+    JSR -120(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+
+function Examine(lock : BPTR;
+                 info : pFileInfoBlock) : Boolean; Assembler;
+asm
+    MOVEM.L d2/a6,-(A7)
+    MOVE.L  _DOSBase,A6
+    MOVE.L  lock,d1
+    MOVE.L  info,d2
+    JSR -102(A6)
+    MOVEM.L (A7)+,d2/a6
+    TST.L   d0
+    SNE     d0
+    NEG.B   d0
+end;
+
+
+function Lock(name : Pchar;
+              accessmode : Longint) : BPTR; Assembler;
+asm
+    MOVEM.L d2/a6,-(A7)
+    MOVE.L  _DOSBase,A6
+    MOVE.L  name,d1
+    MOVE.L  accessmode,d2
+    JSR -084(A6)
+    MOVEM.L (A7)+,d2/a6
+end;
+
+
+procedure UnLock(lock : BPTR); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _DOSBase,A6
+    MOVE.L  lock,d1
+    JSR -090(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+
+function Info(lock : BPTR;
+              params : pInfoData) : Boolean; Assembler;
+asm
+    MOVEM.L d2/a6,-(A7)
+    MOVE.L  _DOSBase,A6
+    MOVE.L  lock,d1
+    MOVE.L  params,d2
+    JSR -114(A6)
+    MOVEM.L (A7)+,d2/a6
+    TST.L   d0
+    SNE     d0
+    NEG.B   d0
+end;
+
+function NameFromLock(Datei : BPTR;
+                      Buffer : Pchar;
+                      BufferSize : Longint) : Boolean; Assembler;
+asm
+    MOVEM.L d2/d3/a6,-(A7)
+    MOVE.L  _DOSBase,A6
+    MOVE.L  Datei,d1
+    MOVE.L  Buffer,d2
+    MOVE.L  BufferSize,d3
+    JSR -402(A6)
+    MOVEM.L (A7)+,d2/d3/a6
+    TST.L   d0
+    SNE     d0
+    NEG.B   d0
+end;
+
+
+function PasToC(var s: string): Pchar;
+var i: integer;
+begin
+    i := Length(s) + 1;
+    if i > 255 then
+    begin
+        Delete(s, 255, 1);      { ensure there is a spare byte }
+        Dec(i)
+    end;
+    s[i]     := #0;
+    PasToC := @s[1]
+end;
+
+procedure CToPas(var s: string);
+begin
+    s[0] := #255;
+    s[0] := Chr(Pos(#0, s) - 1)     { gives -1 (255) if not found }
+end;
+
+
+Function do_exec ( Commandline : pchar; tmp : integer) : integer;
+begin
+end;
+
+Procedure Intr (intno: byte; var regs: registers);
+  Begin
+  { Does not apply to Linux - not implemented }
+  End;
+
+
+Var
+  LastDosExitCode: word;
+
+Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
+  Begin
+  End;
+
+
+Function DosExitCode: Word;
+  Begin
+  End;
+
+
+Function DosVersion: Word;
+  Begin
+  End;
+
+
+
+Procedure GetDate(Var Year, Month, MDay, WDay: Word);
+Var
+  cd    : pClockData;
+  mysec,
+  tick  : Longint;
+begin
+  New(cd);
+  CurrentTime(mysec,tick);
+  Amiga2Date(mysec,cd);
+  Year  := cd^.year;
+  Month := cd^.month;
+  MDay  := cd^.mday;
+  WDay  := cd^.wday;
+  Dispose(cd);
+end;
+
+Procedure SetDate(Year, Month, Day: Word);
+  Begin
+  { !! }
+  End;
+
+
+Procedure GetTime(Var Hour, Minute, Second, Sec100: Word);
+Var
+  mysec,
+  tick    : Longint;
+  cd      : pClockData;
+begin
+  New(cd);
+  CurrentTime(mysec,tick);
+  Amiga2Date(mysec,cd);
+  Hour   := cd^.hour;
+  Minute := cd^.min;
+  Second := cd^.sec;
+  Sec100 := 0;
+  Dispose(cd);
+END;
+
+Procedure SetTime(Hour, Minute, Second, Sec100: Word);
+  Begin
+  { !! }
+  End;
+
+
+Procedure GetCBreak(Var BreakValue: Boolean);
+  Begin
+  { Not implemented for Linux, but set to true as a precaution. }
+  breakvalue:=true
+  End;
+
+
+Procedure SetCBreak(BreakValue: Boolean);
+  Begin
+  { ! No Linux equivalent ! }
+  End;
+
+
+Procedure GetVerify(Var Verify: Boolean);
+   Begin
+   { Not implemented for Linux, but set to true as a precaution. }
+   verify:=true;
+   End;
+
+
+Procedure SetVerify(Verify: Boolean);
+  Begin
+  { ! No Linux equivalent ! }
+  End;
+
+
+Function DiskFree(Drive: Byte): Longint;
+Var
+  MyLock      : BPTR;
+  Inf         : pInfoData;
+  Free        : Longint;
+Begin
+  Free := -1;
+  New(Inf);
+  MyLock := Lock(devicenames[Drive],-2);
+  If MyLock <> NIL then begin
+     if Info(MyLock,Inf) then begin
+        Free := (Inf^.id_NumBlocks * Inf^.id_BytesPerBlock) -
+                (Inf^.id_NumBlocksUsed * Inf^.id_BytesPerBlock);
+     end;
+     Unlock(MyLock);
+  end;
+  Dispose(Inf);
+  diskfree := Free;
+end;
+
+
+
+Function DiskSize(Drive: Byte): Longint;
+Var
+  MyLock      : BPTR;
+  Inf         : pInfoData;
+  Size        : Longint;
+Begin
+  Size := -1;
+  New(Inf);
+  MyLock := Lock(devicenames[Drive],-2);
+  If MyLock <> NIL then begin
+     if Info(MyLock,Inf) then begin
+        Size := (Inf^.id_NumBlocks * Inf^.id_BytesPerBlock);
+     end;
+     Unlock(MyLock);
+  end;
+  Dispose(Inf);
+  disksize := Size;
+end;
+
+
+
+Procedure FindClose(Var f: SearchRec);
+  Begin
+  End;
+
+
+Function FNMatch(Var Pattern: PathStr; Var Name: PathStr): Boolean;
+  Begin {start FNMatch}
+  End;
+
+
+
+Procedure FindWorkProc(Var f: SearchRec);
+  Begin
+  End;
+
+
+Function  FindLastUsed: Word;
+  Begin
+  End;
+
+
+Procedure FindFirst(Const Path: PathStr; Attr: Word; Var f: SearchRec);
+  Begin
+  End;
+
+
+Procedure FindNext(Var f: SearchRec);
+  Begin
+  End;
+
+
+
+Procedure SwapVectors;
+  Begin
+  { Does not apply to Linux - Do Nothing }
+  End;
+
+
+Function EnvCount: Longint;
+
+  Begin
+  End;
+
+
+Function EnvStr(Index: Integer): String;
+  Begin
+  End;
+
+
+Function GetEnv(EnvVar: String): String;
+  Begin
+  End;
+
+Procedure FSplit(Path: PathStr; Var Dir: DirStr; Var Name: NameStr;
+var
+  I: Word;
+begin
+  I := Length(Path);
+  while (I > 0) and not ((Path[I] = '/') or (Path[I] = ':')) do Dec(I);
+  if Path[I] = '/' then
+     dir := Copy(Path, 0, I-1)
+  else dir := Copy(Path,0,I);
+
+  if Length(Path) > Length(dir) then
+     name := Copy(Path, I + 1, Length(Path)-I)
+     else name := '';
+
+  I := Pos('.',Path);
+  if I > 0 then
+     ext := Copy(Path,I,Length(Path)-(I-1))
+     else ext := '';
+end;
+
+Function FExpand(Const Path: PathStr): PathStr;
+var
+    FLock  : BPTR;
+    buffer : PathStr;
+begin
+    FLock := Lock(PasToC(Path),-2);
+    if FLock <> NIL then begin
+       if NameFromLock(FLock,PasToC(buffer),255) then begin
+          CToPas(buffer);
+          Unlock(FLock);
+          FExpend := buffer;
+       end else begin
+          Unlock(FLock);
+          FExpand := '';
+       end;
+    end else FExpand := '';
+end;
+
+
+
+
+
+
+
+Procedure msdos(var regs : registers);
+  Begin
+  { ! Not implemented in Linux ! }
+  End;
+
+
+Procedure getintvec(intno : byte;var vector : pointer);
+  Begin
+  { ! Not implemented in Linux ! }
+  End;
+
+
+Procedure setintvec(intno : byte;vector : pointer);
+  Begin
+  { ! Not implemented in Linux ! }
+  End;
+
+
+Procedure keep(exitcode : word);
+  Begin
+  { ! Not implemented in Linux ! }
+  End;
+
+
+Procedure getfattr(var f; var attr : word);
+  Begin
+  End;
+
+
+Procedure setfattr (var f;attr : word);
+  Begin
+  { ! Not implemented in Linux ! }
+  End;
+
+
+Procedure getftime (var f; var time : longint);
+{
+    This function returns a file's date and time as the number of
+    seconds after January 1, 1978 that the file was created.
+}
+var
+    FInfo : pFileInfoBlock;
+    FTime : Longint;
+    FLock : Longint;
+begin
+    FTime := 0;
+    FLock := Lock(PasToC(filerec(f).name), -2);
+    IF FLock <> NIL then begin
+        New(FInfo);
+        if Examine(FLock, FInfo) then begin
+             with FInfo^.fib_Date do
+             FTime := ds_Days * (24 * 60 * 60) +
+             ds_Minute * 60 +
+             ds_Tick div 50;
+        end else begin
+             FTime := 0;
+        end;
+        Unlock(FLock);
+        Dispose(FInfo);
+    end;
+    time := FTime;
+end;
+
+
+Procedure setftime(var f; time : longint);
+  Begin
+  { ! Not implemented in Linux ! }
+  End;
+
+
+Procedure unpacktime(p : longint;var t : datetime);
+Begin
+  AmigaToDt(p,t);
+End;
+
+
+Procedure packtime(var t : datetime;var p : longint);
+Begin
+  p := DtToAmiga(t);
+end;
+
+Function  fsearch(path : pathstr;dirlist : string) : pathstr;
+  Begin
+  End;
+
+
+Procedure AmigaToDt(SecsPast: LongInt; Var Dt: DateTime);
+var
+  cd : pClockData;
+Begin
+  New(cd);
+  Amiga2Date(SecsPast,cd);
+  Dt.sec   := cd^.sec;
+  Dt.min   := cd^.min;
+  Dt.hour  := cd^.hour;
+  Dt.day   := cd^.mday;
+  Dt.month := cd^.month;
+  Dt.year  := cd^.year;
+  Dispose(cd);
+End;
+
+Function DtToAmiga(DT: DateTime): LongInt;
+var
+  cd : pClockData;
+  temp : Longint;
+Begin
+  New(cd);
+  cd^.sec   := Dt.sec;
+  cd^.min   := Dt.min;
+  cd^.hour  := Dt.hour;
+  cd^.mday  := Dt.day;
+  cd^.month := Dt.month;
+  cd^.year  := Dt.year;
+  temp := Date2Amiga(cd);
+  Dispose(cd);
+  DtToAmiga := temp;
+end;
+
+
+End.
+
+
+
+
+
+
+
+
+

rtl/amiga/exec.pp

@@ -0,0 +1,2602 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Amiga exec.library include file
+    Copyright (c) 1997 by Nils Sjoholm
+    member of the Amiga RTL development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+
+unit Exec;
+
+INTERFACE
+
+TYPE
+
+       STRPTR   = PChar;
+       ULONG    = Longint;
+       LONG     = longint;
+       APTR     = Pointer;
+       BPTR     = Longint;
+       BSTR     = Longint;
+       pWord    = ^Word;
+       pLongint = ^Longint;
+       pInteger = ^Integer;
+
+
+TYPE
+
+{$PACKRECORDS 4}
+
+{ *  List Node Structure.  Each member in a list starts with a Node * }
+
+  pNode = ^tNode;
+  tNode = Record
+    ln_Succ,                { * Pointer to next (successor) * }
+    ln_Pred  : pNode;       { * Pointer to previous (predecessor) * }
+    ln_Type  : Byte;
+    ln_Pri   : Shortint;        { * Priority, for sorting * }
+    ln_Name  : STRPTR;      { * ID string, null terminated * }
+  End;  { * Note: Integer aligned * }
+
+{$PACKRECORDS NORMAL}
+
+{ * minimal node -- no type checking possible * }
+
+  pMinNode = ^tMinNode;
+  tMinNode = Record
+    mln_Succ,
+    mln_Pred  : pMinNode;
+  End;
+
+
+
+{ *
+** Note: Newly initialized IORequests, and software interrupt structures
+** used with Cause(), should have type NT_UNKNOWN.  The OS will assign a type
+** when they are first used.
+* }
+
+{ *----- Node Types for LN_TYPE -----* }
+
+Const
+
+  NT_UNKNOWN      =  0;
+  NT_TASK     =  1;  { * Exec task * }
+  NT_INTERRUPT    =  2;
+  NT_DEVICE   =  3;
+  NT_MSGPORT      =  4;
+  NT_MESSAGE      =  5;  { * Indicates message currently pending * }
+  NT_FREEMSG      =  6;
+  NT_REPLYMSG     =  7;  { * Message has been replied * }
+  NT_RESOURCE     =  8;
+  NT_LIBRARY      =  9;
+  NT_MEMORY   = 10;
+  NT_SOFTINT      = 11;  { * Internal flag used by SoftInits * }
+  NT_FONT     = 12;
+  NT_PROCESS      = 13;  { * AmigaDOS Process * }
+  NT_SEMAPHORE    = 14;
+  NT_SIGNALSEM    = 15;  { * signal semaphores * }
+  NT_BOOTNODE     = 16;
+  NT_KICKMEM      = 17;
+  NT_GRAPHICS     = 18;
+  NT_DEATHMESSAGE = 19;
+
+  NT_USER     = 254;  { * User node types work down from here * }
+  NT_EXTENDED     = 255;
+
+{
+    This file defines Exec system lists, which are used to link
+    various things.  Exec provides several routines to handle list
+    processing (defined at the bottom of this file), so you can
+    use these routines to save yourself the trouble of writing a list
+    package.
+}
+
+
+Type
+
+{ normal, full featured list }
+
+    pList = ^tList;
+    tList = record
+    lh_Head     : pNode;
+    lh_Tail     : pNode;
+    lh_TailPred : pNode;
+    lh_Type     : Byte;
+    l_pad       : Byte;
+    end;
+
+{ minimum list -- no type checking possible }
+
+    pMinList = ^tMinList;
+    tMinList = record
+    mlh_Head        : pMinNode;
+    mlh_Tail        : pMinNode;
+    mlh_TailPred    : pMinNode;
+    end;
+
+
+
+{ ********************************************************************
+*
+*  Format of the alert error number:
+*
+*    +-+-------------+----------------+--------------------------------+
+*    |D|  SubSysId   |  General Error |    SubSystem Specific Error    |
+*    +-+-------------+----------------+--------------------------------+
+*     1    7 bits          8 bits                  16 bits
+*
+*                    D:  DeadEnd alert
+*             SubSysId:  indicates ROM subsystem number.
+*        General Error:  roughly indicates what the error was
+*       Specific Error:  indicates more detail
+*********************************************************************}
+
+const
+{*********************************************************************
+*
+*  Hardware/CPU specific alerts:  They may show without the 8 at the
+*  front of the number.  These are CPU/68000 specific.  See 68$0
+*  programmer's manuals for more details.
+*
+*********************************************************************}
+    ACPU_BusErr     = $80000002;      { Hardware bus fault/access error }
+    ACPU_AddressErr = $80000003;      { Illegal address access (ie: odd) }
+    ACPU_InstErr    = $80000004;      { Illegal instruction }
+    ACPU_DivZero    = $80000005;      { Divide by zero }
+    ACPU_CHK        = $80000006;      { Check instruction error }
+    ACPU_TRAPV      = $80000007;      { TrapV instruction error }
+    ACPU_PrivErr    = $80000008;      { Privilege violation error }
+    ACPU_Trace      = $80000009;      { Trace error }
+    ACPU_LineA      = $8000000A;      { Line 1010 Emulator error }
+    ACPU_LineF      = $8000000B;      { Line 1111 Emulator error }
+    ACPU_Format     = $8000000E;      { Stack frame format error }
+    ACPU_Spurious   = $80000018;      { Spurious interrupt error }
+    ACPU_AutoVec1   = $80000019;      { AutoVector Level 1 interrupt error }
+    ACPU_AutoVec2   = $8000001A;      { AutoVector Level 2 interrupt error }
+    ACPU_AutoVec3   = $8000001B;      { AutoVector Level 3 interrupt error }
+    ACPU_AutoVec4   = $8000001C;      { AutoVector Level 4 interrupt error }
+    ACPU_AutoVec5   = $8000001D;      { AutoVector Level 5 interrupt error }
+    ACPU_AutoVec6   = $8000001E;      { AutoVector Level 6 interrupt error }
+    ACPU_AutoVec7   = $8000001F;      { AutoVector Level 7 interrupt error }
+
+
+{ ********************************************************************
+*
+*  General Alerts
+*
+*  For example: timer.device cannot open math.library would be $05038015
+*
+*       Alert(AN_TimerDev|AG_OpenLib|AO_MathLib);
+*
+********************************************************************}
+
+
+CONST
+
+{ ------ alert types }
+  AT_DeadEnd    = $80000000;
+  AT_Recovery   = $00000000;
+
+
+{ ------ general purpose alert codes }
+  AG_NoMemory   = $00010000;
+  AG_MakeLib    = $00020000;
+  AG_OpenLib    = $00030000;
+  AG_OpenDev    = $00040000;
+  AG_OpenRes    = $00050000;
+  AG_IOError    = $00060000;
+  AG_NoSignal   = $00070000;
+  AG_BadParm    = $00080000;
+  AG_CloseLib   = $00090000;    { usually too many closes }
+  AG_CloseDev   = $000A0000;    { or a mismatched close }
+  AG_ProcCreate = $000B0000;    { Process creation failed }
+
+
+{ ------ alert objects: }
+  AO_ExecLib      = $00008001;
+  AO_GraphicsLib  = $00008002;
+  AO_LayersLib    = $00008003;
+  AO_Intuition    = $00008004;
+  AO_MathLib      = $00008005;
+  AO_DOSLib       = $00008007;
+  AO_RAMLib       = $00008008;
+  AO_IconLib      = $00008009;
+  AO_ExpansionLib = $0000800A;
+  AO_DiskfontLib  = $0000800B;
+  AO_UtilityLib   = $0000800C;
+  AO_KeyMapLib    = $0000800D;
+
+  AO_AudioDev     = $00008010;
+  AO_ConsoleDev   = $00008011;
+  AO_GamePortDev  = $00008012;
+  AO_KeyboardDev  = $00008013;
+  AO_TrackDiskDev = $00008014;
+  AO_TimerDev     = $00008015;
+
+  AO_CIARsrc    = $00008020;
+  AO_DiskRsrc   = $00008021;
+  AO_MiscRsrc   = $00008022;
+
+  AO_BootStrap  = $00008030;
+  AO_Workbench  = $00008031;
+  AO_DiskCopy   = $00008032;
+  AO_GadTools   = $00008033;
+  AO_Unknown    = $00008035;
+
+
+
+{ ********************************************************************
+*
+*   Specific Alerts:
+*
+********************************************************************}
+
+{ ------ exec.library }
+
+  AN_ExecLib    = $01000000;
+  AN_ExcptVect  = $01000001; {  68000 exception vector checksum (obs.) }
+  AN_BaseChkSum = $01000002; {  Execbase checksum (obs.) }
+  AN_LibChkSum  = $01000003; {  Library checksum failure }
+
+  AN_MemCorrupt = $81000005; {  Corrupt memory list detected in FreeMem }
+  AN_IntrMem    = $81000006; {  No memory for interrupt servers }
+  AN_InitAPtr   = $01000007; {  InitStruct() of an APTR source (obs.) }
+  AN_SemCorrupt = $01000008; {  A semaphore is in an illegal state
+                                      at ReleaseSempahore() }
+  AN_FreeTwice    = $01000009; {  Freeing memory already freed }
+  AN_BogusExcpt   = $8100000A; {  illegal 68k exception taken (obs.) }
+  AN_IOUsedTwice  = $0100000B; {  Attempt to reuse active IORequest }
+  AN_MemoryInsane = $0100000C; {  Sanity check on memory list failed
+                                      during AvailMem(MEMF_LARGEST) }
+  AN_IOAfterClose = $0100000D; {  IO attempted on closed IORequest }
+  AN_StackProbe   = $0100000E; {  Stack appears to extend out of range }
+  AN_BadFreeAddr  = $0100000F; {  Memory header not located. [ Usually an
+                                  invalid address passed to FreeMem() ] }
+  AN_BadSemaphore = $01000010; { An attempt was made to use the old
+                                      message semaphores. }
+
+{ ------ graphics.library }
+
+  AN_GraphicsLib  = $02000000;
+  AN_GfxNoMem     = $82010000;  {  graphics out of memory }
+  AN_GfxNoMemMspc = $82010001;  {  MonitorSpec alloc, no memory }
+  AN_LongFrame    = $82010006;  {  long frame, no memory }
+  AN_ShortFrame   = $82010007;  {  short frame, no memory }
+  AN_TextTmpRas   = $02010009;  {  text, no memory for TmpRas }
+  AN_BltBitMap    = $8201000A;  {  BltBitMap, no memory }
+  AN_RegionMemory = $8201000B;  {  regions, memory not available }
+  AN_MakeVPort    = $82010030;  {  MakeVPort, no memory }
+  AN_GfxNewError  = $0200000C;
+  AN_GfxFreeError = $0200000D;
+
+  AN_GfxNoLCM     = $82011234;  {  emergency memory not available }
+
+  AN_ObsoleteFont = $02000401;  {  unsupported font description used }
+
+{ ------ layers.library }
+
+  AN_LayersLib    = $03000000;
+  AN_LayersNoMem  = $83010000;  {  layers out of memory }
+
+{ ------ intuition.library }
+  AN_Intuition    = $04000000;
+  AN_GadgetType   = $84000001;  {  unknown gadget type }
+  AN_BadGadget    = $04000001;  {  Recovery form of AN_GadgetType }
+  AN_CreatePort   = $84010002;  {  create port, no memory }
+  AN_ItemAlloc    = $04010003;  {  item plane alloc, no memory }
+  AN_SubAlloc     = $04010004;  {  sub alloc, no memory }
+  AN_PlaneAlloc   = $84010005;  {  plane alloc, no memory }
+  AN_ItemBoxTop   = $84000006;  {  item box top < RelZero }
+  AN_OpenScreen   = $84010007;  {  open screen, no memory }
+  AN_OpenScrnRast = $84010008;  {  open screen, raster alloc, no memory }
+  AN_SysScrnType  = $84000009;  {  open sys screen, unknown type }
+  AN_AddSWGadget  = $8401000A;  {  add SW gadgets, no memory }
+  AN_OpenWindow   = $8401000B;  {  open window, no memory }
+  AN_BadState     = $8400000C;  {  Bad State Return entering Intuition }
+  AN_BadMessage   = $8400000D;  {  Bad Message received by IDCMP }
+  AN_WeirdEcho    = $8400000E;  {  Weird echo causing incomprehension }
+  AN_NoConsole    = $8400000F;  {  couldn't open the Console Device }
+  AN_NoISem       = $04000010;  { Intuition skipped obtaining a sem }
+  AN_ISemOrder    = $04000011;  { Intuition obtained a sem in bad order }
+
+{ ------ math.library }
+
+  AN_MathLib      = $05000000;
+
+{ ------ dos.library }
+
+  AN_DOSLib       = $07000000;
+  AN_StartMem     = $07010001; {  no memory at startup }
+  AN_EndTask      = $07000002; {  EndTask didn't }
+  AN_QPktFail     = $07000003; {  Qpkt failure }
+  AN_AsyncPkt     = $07000004; {  Unexpected packet received }
+  AN_FreeVec      = $07000005; {  Freevec failed }
+  AN_DiskBlkSeq   = $07000006; {  Disk block sequence error }
+  AN_BitMap       = $07000007; {  Bitmap corrupt }
+  AN_KeyFree      = $07000008; {  Key already free }
+  AN_BadChkSum    = $07000009; {  Invalid checksum }
+  AN_DiskError    = $0700000A; {  Disk Error }
+  AN_KeyRange     = $0700000B; {  Key out of range }
+  AN_BadOverlay   = $0700000C; {  Bad overlay }
+  AN_BadInitFunc  = $0700000D; {  Invalid init packet for cli/shell }
+  AN_FileReclosed = $0700000E; {  A filehandle was closed more than once }
+
+{ ------ ramlib.library }
+
+  AN_RAMLib       = $08000000;
+  AN_BadSegList   = $08000001;  {  no overlays in library seglists }
+
+{ ------ icon.library }
+
+  AN_IconLib      = $09000000;
+
+{ ------ expansion.library }
+
+  AN_ExpansionLib       = $0A000000;
+  AN_BadExpansionFree   = $0A000001; {  freeed free region }
+
+{ ------ diskfont.library }
+
+  AN_DiskfontLib        = $0B000000;
+
+{ ------ audio.device }
+
+  AN_AudioDev   = $10000000;
+
+{ ------ console.device }
+
+  AN_ConsoleDev = $11000000;
+  AN_NoWindow   = $11000001;    {  Console can't open initial window }
+
+{ ------ gameport.device }
+
+  AN_GamePortDev        = $12000000;
+
+{ ------ keyboard.device }
+
+  AN_KeyboardDev        = $13000000;
+
+{ ------ trackdisk.device }
+
+  AN_TrackDiskDev = $14000000;
+  AN_TDCalibSeek  = $14000001;  {  calibrate: seek error }
+  AN_TDDelay      = $14000002;  {  delay: error on timer wait }
+
+{ ------ timer.device }
+
+  AN_TimerDev     = $15000000;
+  AN_TMBadReq     = $15000001; {  bad request }
+  AN_TMBadSupply  = $15000002; {  power supply -- no 50/60Hz ticks }
+
+{ ------ cia.resource }
+
+  AN_CIARsrc      = $20000000;
+
+{ ------ disk.resource }
+
+  AN_DiskRsrc   = $21000000;
+  AN_DRHasDisk  = $21000001;    {  get unit: already has disk }
+  AN_DRIntNoAct = $21000002;    {  interrupt: no active unit }
+
+{ ------ misc.resource }
+
+  AN_MiscRsrc   = $22000000;
+
+{ ------ bootstrap }
+
+  AN_BootStrap  = $30000000;
+  AN_BootError  = $30000001;    {  boot code returned an error }
+
+{ ------ Workbench }
+
+  AN_Workbench          = $31000000;
+  AN_NoFonts            = $B1000001;
+  AN_WBBadStartupMsg1   = $31000001;
+  AN_WBBadStartupMsg2   = $31000002;
+  AN_WBBadIOMsg         = $31000003;
+
+  AN_WBReLayoutToolMenu          = $B1010009;
+
+{ ------ DiskCopy }
+
+  AN_DiskCopy   = $32000000;
+
+{ ------ toolkit for Intuition }
+
+  AN_GadTools   = $33000000;
+
+{ ------ System utility library }
+
+  AN_UtilityLib = $34000000;
+
+{ ------ For use by any application that needs it }
+
+  AN_Unknown    = $35000000;
+
+
+
+CONST
+
+  IOERR_OPENFAIL   = -1;    {  device/unit failed to open  }
+  IOERR_ABORTED    = -2;    {  request terminated early [after AbortIO()]  }
+  IOERR_NOCMD      = -3;    {  command not supported by device  }
+  IOERR_BADLENGTH  = -4;    {  not a valid length (usually IO_LENGTH)  }
+  IOERR_BADADDRESS = -5;    {  invalid address (misaligned or bad range)  }
+  IOERR_UNITBUSY   = -6;    {  device opens ok, but requested unit is busy  }
+  IOERR_SELFTEST   = -7;    {  hardware failed self-test  }
+
+
+
+type
+    pResident = ^tResident;
+    tResident = record
+    rt_MatchWord  : Word;        { Integer to match on (ILLEGAL)  }
+    rt_MatchTag   : pResident;    { pointer to the above        }
+    rt_EndSkip    : Pointer;      { address to continue scan    }
+    rt_Flags      : Byte;        { various tag flags           }
+    rt_Version    : Byte;        { release version number      }
+    rt_Type       : Byte;        { type of module (NT_mumble)  }
+    rt_Pri        : Shortint;         { initialization priority     }
+    rt_Name       : STRPTR;       { pointer to node name        }
+    rt_IdString   : STRPTR;       { pointer to ident string     }
+    rt_Init       : Pointer;      { pointer to init code        }
+    end;
+
+const
+
+
+    RTC_MATCHWORD   = $4AFC;
+
+    RTF_AUTOINIT    = $80;
+    RTF_AFTERDOS    = $04;
+    RTF_SINGLETASK  = $02;
+    RTF_COLDSTART   = $01;
+
+
+{ Compatibility: }
+
+    RTM_WHEN        = $03;
+    RTW_COLDSTART   = $01;
+    RTW_NEVER       = $00;
+
+
+
+TYPE
+
+{ ****** MemChunk **************************************************** }
+
+  pMemChunk = ^tMemChunk;
+  tMemChunk = Record
+    mc_Next  : pMemChunk;       { * pointer to next chunk * }
+    mc_Bytes : ULONG;           { * chunk byte size     * }
+  End;
+
+
+{ ****** MemHeader *************************************************** }
+
+  pMemHeader = ^tMemHeader;
+  tMemHeader = Record
+    mh_Node       : tNode;
+    mh_Attributes : Word;       { * characteristics of this region * }
+    mh_First      : pMemChunk;   { * first free region          * }
+    mh_Lower,                    { * lower memory bound         * }
+    mh_Upper      : Pointer;     { * upper memory bound+1       * }
+    mh_Free       : Ulong;       { * total number of free bytes * }
+  End;
+
+
+{ ****** MemEntry **************************************************** }
+
+  pMemUnit = ^tMemUnit;
+  tMemUnit = Record
+      meu_Reqs  : ULONG;        { * the AllocMem requirements * }
+      meu_Addr  : Pointer;      { * the address of this memory region * }
+  End;
+
+  pMemEntry = ^tMemEntry;
+  tMemEntry = Record
+    me_Un       : tMemUnit;
+    me_Length   : ULONG;        { * the length of this memory region * }
+  End;
+
+
+{ ****** MemList ***************************************************** }
+
+{ * Note: sizeof(struct MemList) includes the size of the first MemEntry! * }
+
+  pMemList = ^tMemList;
+  tMemList = Record
+    ml_Node       : tNode;
+    ml_NumEntries : Word;      { * number of entries in this struct * }
+    ml_ME         : Array [0..0] of tMemEntry;    { * the first entry * }
+  End;
+
+{ *----- Memory Requirement Types ---------------------------* }
+{ *----- See the AllocMem() documentation for details--------* }
+
+Const
+
+   MEMF_ANY      = %000000000000000000000000;   { * Any type of memory will do * }
+   MEMF_PUBLIC   = %000000000000000000000001;
+   MEMF_CHIP     = %000000000000000000000010;
+   MEMF_FAST     = %000000000000000000000100;
+   MEMF_LOCAL    = %000000000000000100000000;
+   MEMF_24BITDMA = %000000000000001000000000;   { * DMAable memory within 24 bits of address * }
+   MEMF_KICK     = %000000000000010000000000;   { Memory that can be used for KickTags }
+
+   MEMF_CLEAR    = %000000010000000000000000;
+   MEMF_LARGEST  = %000000100000000000000000;
+   MEMF_REVERSE  = %000001000000000000000000;
+   MEMF_TOTAL    = %000010000000000000000000;   { * AvailMem: return total size of memory * }
+   MEMF_NO_EXPUNGE = $80000000;   {AllocMem: Do not cause expunge on failure }
+
+   MEM_BLOCKSIZE = 8;
+   MEM_BLOCKMASK = MEM_BLOCKSIZE-1;
+
+Type
+{***** MemHandlerData *********************************************}
+{ Note:  This structure is *READ ONLY* and only EXEC can create it!}
+
+ pMemHandlerData = ^tMemHandlerData;
+ tMemHandlerData = Record
+        memh_RequestSize,       { Requested allocation size }
+        memh_RequestFlags,      { Requested allocation flags }
+        memh_Flags  : ULONG;    { Flags (see below) }
+ end;
+
+const
+    MEMHF_RECYCLE  = 1; { 0==First time, 1==recycle }
+
+{***** Low Memory handler return values **************************}
+    MEM_DID_NOTHING = 0;     { Nothing we could do... }
+    MEM_ALL_DONE    = -1;    { We did all we could do }
+    MEM_TRY_AGAIN   = 1;     { We did some, try the allocation again }
+
+
+type
+    pInterrupt = ^tInterrupt;
+    tInterrupt = record
+        is_Node : tNode;
+        is_Data : Pointer;      { Server data segment }
+        is_Code : Pointer;      { Server code entry }
+    end;
+
+    pIntVector = ^tIntVector;
+    tIntVector = record          { For EXEC use ONLY! }
+        iv_Data : Pointer;
+        iv_Code : Pointer;
+        iv_Node : pNode;
+    end;
+
+    pSoftIntList = ^tSoftIntList;
+    tSoftIntList = record        { For EXEC use ONLY! }
+        sh_List : tList;
+        sh_Pad  : Word;
+    end;
+
+const
+    SIH_PRIMASK = $F0;
+
+{ this is a fake INT definition, used only for AddIntServer and the like }
+
+    INTB_NMI    = 15;
+    INTF_NMI    = $0080;
+
+{
+    Every Amiga Task has one of these Task structures associated with it.
+    To find yours, use FindTask(Nil).  AmigaDOS processes tack a few more
+    values on to the end of this structure, which is the difference between
+    Tasks and Processes.
+}
+
+type
+  
+    pTask = ^tTask;
+    tTask = record
+        tc_Node         : tNode;
+        tc_Flags        : Byte;
+        tc_State        : Byte;
+        tc_IDNestCnt    : Shortint;         { intr disabled nesting         }
+        tc_TDNestCnt    : Shortint;         { task disabled nesting         }
+        tc_SigAlloc     : ULONG;        { sigs allocated                }
+        tc_SigWait      : ULONG;        { sigs we are waiting for       }
+        tc_SigRecvd     : ULONG;        { sigs we have received         }
+        tc_SigExcept    : ULONG;        { sigs we will take excepts for }
+        tc_TrapAlloc    : Word;        { traps allocated               }
+        tc_TrapAble     : Word;        { traps enabled                 }
+        tc_ExceptData   : Pointer;      { points to except data         }
+        tc_ExceptCode   : Pointer;      { points to except code         }
+        tc_TrapData     : Pointer;      { points to trap data           }
+        tc_TrapCode     : Pointer;      { points to trap code           }
+        tc_SPReg        : Pointer;      { stack pointer                 }
+        tc_SPLower      : Pointer;      { stack lower bound             }
+        tc_SPUpper      : Pointer;      { stack upper bound + 2         }
+        tc_Switch       : Pointer;      { task losing CPU               }
+        tc_Launch       : Pointer;      { task getting CPU              }
+        tc_MemEntry     : tList;        { allocated memory              }
+        tc_UserData     : Pointer;      { per task data                 }
+    end;
+
+{
+ * Stack swap structure as passed to StackSwap()
+ }
+  pStackSwapStruct = ^tStackSwapStruct;
+  tStackSwapStruct = Record
+        stk_Lower       : Pointer;      { Lowest byte of stack }
+        stk_Upper       : ULONG;        { Upper end of stack (size + Lowest) }
+        stk_Pointer     : Pointer;      { Stack pointer at switch point }
+  end;
+
+
+
+{----- Flag Bits ------------------------------------------}
+
+const
+
+    TB_PROCTIME         = 0;
+    TB_ETASK            = 3;
+    TB_STACKCHK         = 4;
+    TB_EXCEPT           = 5;
+    TB_SWITCH           = 6;
+    TB_LAUNCH           = 7;
+
+    TF_PROCTIME         = 1;
+    TF_ETASK            = 8;
+    TF_STACKCHK         = 16;
+    TF_EXCEPT           = 32;
+    TF_SWITCH           = 64;
+    TF_LAUNCH           = 128;
+
+{----- Task States ----------------------------------------}
+
+    TS_INVALID          = 0;
+    TS_ADDED            = 1;
+    TS_RUN              = 2;
+    TS_READY            = 3;
+    TS_WAIT             = 4;
+    TS_EXCEPT           = 5;
+    TS_REMOVED          = 6;
+
+{----- Predefined Signals -------------------------------------}
+
+    SIGB_ABORT          = 0;
+    SIGB_CHILD          = 1;
+    SIGB_BLIT           = 4;
+    SIGB_SINGLE         = 4;
+    SIGB_INTUITION      = 5;
+    SIGB_DOS            = 8;
+
+    SIGF_ABORT          = 1;
+    SIGF_CHILD          = 2;
+    SIGF_BLIT           = 16;
+    SIGF_SINGLE         = 16;
+    SIGF_INTUITION      = 32;
+    SIGF_DOS            = 256;
+
+
+
+{
+    This file defines ports and messages, which are used for inter-
+    task communications using the routines defined toward the
+    bottom of this file.
+}
+
+type
+
+{****** MsgPort *****************************************************}
+
+    pMsgPort = ^tMsgPort;
+    tMsgPort = record
+    mp_Node     : tNode;
+    mp_Flags    : Byte;
+    mp_SigBit   : Byte;     { signal bit number    }
+    mp_SigTask  : Pointer;   { task to be signalled (TaskPtr) }
+    mp_MsgList  : tList;     { message linked list  }
+    end;
+
+{****** Message *****************************************************}
+
+    pMessage = ^tMessage;
+    tMessage = record
+    mn_Node       : tNode;
+    mn_ReplyPort  : pMsgPort;   { message reply port }
+    mn_Length     : Word;      { message len in bytes }
+    end;
+
+
+
+{ mp_Flags: Port arrival actions (PutMsg) }
+
+CONST
+
+  PF_ACTION = 3;    { * Mask * }
+  PA_SIGNAL = 0;    { * Signal task in mp_SigTask * }
+  PA_SOFTINT    = 1;    { * Signal SoftInt in mp_SoftInt/mp_SigTask * }
+  PA_IGNORE = 2;    { * Ignore arrival * }
+
+
+        { Semaphore }
+type
+    pSemaphore = ^tSemaphore;
+    tSemaphore = record
+        sm_MsgPort : tMsgPort;
+        sm_Bids    : Integer;
+    end;
+
+{  This is the structure used to request a signal semaphore }
+
+    pSemaphoreRequest = ^tSemaphoreRequest;
+    tSemaphoreRequest = record
+        sr_Link    : tMinNode;
+        sr_Waiter  : pTask;
+    end;
+
+{ The actual semaphore itself }
+
+    pSignalSemaphore = ^tSignalSemaphore;
+    tSignalSemaphore = record
+        ss_Link         : tNode;
+        ss_NestCount    : Integer;
+        ss_WaitQueue    : tMinList;
+        ss_MultipleLink : tSemaphoreRequest;
+        ss_Owner        : pTask;
+        ss_QueueCount   : Integer;
+    end;
+
+
+{  ***** Semaphore procure message (for use in V39 Procure/Vacate *** }
+
+
+ pSemaphoreMessage = ^tSemaphoreMessage;
+ tSemaphoreMessage = Record
+   ssm_Message   : tMessage;
+   ssm_Semaphore : pSignalSemaphore;
+ end;
+
+const
+ SM_SHARED      = 1;
+ SM_EXCLUSIVE   = 0;
+
+
+CONST
+
+{ ------ Special Constants --------------------------------------- }
+  LIB_VECTSIZE  =  6;   {  Each library entry takes 6 bytes  }
+  LIB_RESERVED  =  4;   {  Exec reserves the first 4 vectors  }
+  LIB_BASE  = (-LIB_VECTSIZE);
+  LIB_USERDEF   = (LIB_BASE-(LIB_RESERVED*LIB_VECTSIZE));
+  LIB_NONSTD    = (LIB_USERDEF);
+
+{ ------ Standard Functions -------------------------------------- }
+  LIB_OPEN  =  -6;
+  LIB_CLOSE = -12;
+  LIB_EXPUNGE   = -18;
+  LIB_EXTFUNC   = -24;  {  for future expansion  }
+
+TYPE
+
+{ ------ Library Base Structure ---------------------------------- }
+{  Also used for Devices and some Resources  }
+
+    pLibrary = ^tLibrary;
+    tLibrary = record
+        lib_Node     : tNode;
+        lib_Flags,
+        lib_pad      : Byte;
+        lib_NegSize,            {  number of bytes before library  }
+        lib_PosSize,            {  number of bytes after library  }
+        lib_Version,            {  major  }
+        lib_Revision : Word;   {  minor  }
+        lib_IdString : STRPTR;  {  ASCII identification  }
+        lib_Sum      : ULONG;   {  the checksum itself  }
+        lib_OpenCnt  : Word;   {  number of current opens  }
+    end;                {  * Warning: size is not a longword multiple ! * }
+
+CONST
+
+{  lib_Flags bit definitions (all others are system reserved)  }
+
+  LIBF_SUMMING = %00000001; {  we are currently checksumming  }
+  LIBF_CHANGED = %00000010; {  we have just changed the lib  }
+  LIBF_SUMUSED = %00000100; {  set if we should bother to sum  }
+  LIBF_DELEXP  = %00001000; {  delayed expunge  }
+
+{
+    This file defines the constants and types required to use
+    Amiga device IO routines, which are also defined here.
+}
+
+
+TYPE
+
+{***** Device *****************************************************}
+  pDevice = ^tDevice;
+  tDevice = record
+    dd_Library : tLibrary;
+  end;
+
+{***** Unit *******************************************************}
+  pUnit = ^tUnit;
+  tUnit = record
+      unit_MsgPort : tMsgPort;     { queue for unprocessed messages }
+                    { instance of msgport is recommended }
+      unit_flags,
+      unit_pad     : Byte;
+      unit_OpenCnt : Word;       { number of active opens }
+  end;
+
+Const
+  UNITF_ACTIVE  = %00000001;
+  UNITF_INTASK  = %00000010;
+
+type
+
+    pIORequest = ^tIORequest;
+    tIORequest = record
+    io_Message  : tMessage;
+    io_Device   : pDevice;      { device node pointer  }
+    io_Unit     : pUnit;        { unit (driver private)}
+    io_Command  : Word;        { device command }
+    io_Flags    : Byte;
+    io_Error    : Shortint;         { error or warning num }
+    end;
+
+    pIOStdReq = ^tIOStdReq;
+    tIOStdReq = record
+    io_Message  : tMessage;
+    io_Device   : pDevice;      { device node pointer  }
+    io_Unit     : pUnit;        { unit (driver private)}
+    io_Command  : Word;        { device command }
+    io_Flags    : Byte;
+    io_Error    : Shortint;         { error or warning num }
+    io_Actual   : ULONG;        { actual number of bytes transferred }
+    io_Length   : ULONG;        { requested number bytes transferred}
+    io_Data     : Pointer;      { points to data area }
+    io_Offset   : ULONG;        { offset for block structured devices }
+    end;
+
+
+{ library vector offsets for device reserved vectors }
+
+const
+    DEV_BEGINIO = -30;
+    DEV_ABORTIO = -36;
+
+{ io_Flags defined bits }
+
+    IOB_QUICK   = 0;
+    IOF_QUICK   = 1;
+
+    CMD_INVALID = 0;
+    CMD_RESET   = 1;
+    CMD_READ    = 2;
+    CMD_WRITE   = 3;
+    CMD_UPDATE  = 4;
+    CMD_CLEAR   = 5;
+    CMD_STOP    = 6;
+    CMD_START   = 7;
+    CMD_FLUSH   = 8;
+
+    CMD_NONSTD  = 9;
+
+
+
+
+{  Definition of the Exec library base structure (pointed to by location 4).
+** Most fields are not to be viewed or modified by user programs.  Use
+** extreme caution.
+ }
+
+type
+
+pExecBase = ^tExecBase;
+tExecBase = Record
+        LibNode    : tLibrary;   {  Standard library node  }
+
+{ ******* Static System Variables ******* }
+
+        SoftVer      : Word;   {  kickstart release number (obs.)  }
+        LowMemChkSum : Integer;    {  checksum of 68000 trap vectors  }
+        ChkBase      : ULONG;   {  system base pointer complement  }
+        ColdCapture,            {  coldstart soft capture vector  }
+        CoolCapture,            {  coolstart soft capture vector  }
+        WarmCapture,            {  warmstart soft capture vector  }
+        SysStkUpper,            {  system stack base   (upper bound)  }
+        SysStkLower  : Pointer; {  top of system stack (lower bound)  }
+        MaxLocMem    : ULONG;   {  top of chip memory  }
+        DebugEntry,             {  global debugger entry point  }
+        DebugData,              {  global debugger data segment  }
+        AlertData,              {  alert data segment  }
+        MaxExtMem    : Pointer; {  top of extended mem, or null if none  }
+
+        ChkSum       : Word;   {  for all of the above (minus 2)  }
+
+{ ***** Interrupt Related ************************************** }
+
+        IntVects     : Array[0..15] of tIntVector;
+
+{ ***** Dynamic System Variables ************************************ }
+
+        ThisTask     : pTask;   {  pointer to current task (readable)  }
+
+        IdleCount,              {  idle counter  }
+        DispCount    : ULONG;   {  dispatch counter  }
+        Quantum,                {  time slice quantum  }
+        Elapsed,                {  current quantum ticks  }
+        SysFlags     : Word;   {  misc internal system flags  }
+        IDNestCnt,              {  interrupt disable nesting count  }
+        TDNestCnt    : Shortint;    {  task disable nesting count  }
+
+        AttnFlags,              {  special attention flags (readable)  }
+        AttnResched  : Word;   {  rescheduling attention  }
+        ResModules,             {  resident module array pointer  }
+        TaskTrapCode,
+        TaskExceptCode,
+        TaskExitCode : Pointer;
+        TaskSigAlloc : ULONG;
+        TaskTrapAlloc: Word;
+
+
+{ ***** System Lists (private!) ******************************* }
+
+        MemList,
+        ResourceList,
+        DeviceList,
+        IntrList,
+        LibList,
+        PortList,
+        TaskReady,
+        TaskWait     : tList;
+
+        SoftInts     : Array[0..4] of tSoftIntList;
+
+{ ***** Other Globals ****************************************** }
+
+        LastAlert    : Array[0..3] of LONG;
+
+        {  these next two variables are provided to allow
+        ** system developers to have a rough idea of the
+        ** period of two externally controlled signals --
+        ** the time between vertical blank interrupts and the
+        ** external line rate (which is counted by CIA A's
+        ** "time of day" clock).  In general these values
+        ** will be 50 or 60, and may or may not track each
+        ** other.  These values replace the obsolete AFB_PAL
+        ** and AFB_50HZ flags.
+         }
+
+        VBlankFrequency,                {  (readable)  }
+        PowerSupplyFrequency : Byte;   {  (readable)  }
+
+        SemaphoreList    : tList;
+
+        {  these next two are to be able to kickstart into user ram.
+        ** KickMemPtr holds a singly linked list of MemLists which
+        ** will be removed from the memory list via AllocAbs.  If
+        ** all the AllocAbs's succeeded, then the KickTagPtr will
+        ** be added to the rom tag list.
+         }
+
+        KickMemPtr,             {  ptr to queue of mem lists  }
+        KickTagPtr,             {  ptr to rom tag queue  }
+        KickCheckSum : Pointer; {  checksum for mem and tags  }
+
+{ ***** V36 Exec additions start here ************************************* }
+
+        ex_Pad0           : Word;
+        ex_Reserved0      : ULONG;
+        ex_RamLibPrivate  : Pointer;
+
+        {  The next ULONG contains the system "E" clock frequency,
+        ** expressed in Hertz.  The E clock is used as a timebase for
+        ** the Amiga's 8520 I/O chips. (E is connected to "02").
+        ** Typical values are 715909 for NTSC, or 709379 for PAL.
+         }
+
+        ex_EClockFrequency,         {  (readable)  }
+        ex_CacheControl,            {  Private to CacheControl calls  }
+        ex_TaskID         : ULONG;  {  Next available task ID  }
+
+        ex_Reserved1      : Array[0..4] of ULONG;
+
+        ex_MMULock        : Pointer;    {  private  }
+
+        ex_Reserved2      : Array[0..2] of ULONG;
+{***** V39 Exec additions start here *************************************}
+
+        { The following list and data element are used
+         * for V39 exec's low memory handler...
+         }
+        ex_MemHandlers    : tMinList; { The handler list }
+        ex_MemHandler     : Pointer;          { Private! handler pointer }
+        ex_Reserved       : Array[0..1] of Shortint;
+end;
+
+
+{ ***** Bit defines for AttnFlags (see above) ***************************** }
+
+{   Processors and Co-processors:  }
+
+CONST
+
+  AFB_68010     = 0;    {  also set for 68020  }
+  AFB_68020     = 1;    {  also set for 68030  }
+  AFB_68030     = 2;    {  also set for 68040  }
+  AFB_68040     = 3;
+  AFB_68881     = 4;    {  also set for 68882  }
+  AFB_68882     = 5;
+  AFB_FPU40     = 6;    {  Set if 68040 FPU }
+
+  AFF_68010     = %00000001;
+  AFF_68020     = %00000010;
+  AFF_68030     = %00000100;
+  AFF_68040     = %00001000;
+  AFF_68881     = %00010000;
+  AFF_68882     = %00100000;
+  AFF_FPU40     = %01000000;
+
+{    AFB_RESERVED8 = %000100000000;  }
+{    AFB_RESERVED9 = %001000000000;  }
+
+
+{ ***** Selected flag definitions for Cache manipulation calls ********* }
+
+  CACRF_EnableI       = %0000000000000001;  { Enable instruction cache  }
+  CACRF_FreezeI       = %0000000000000010;  { Freeze instruction cache  }
+  CACRF_ClearI        = %0000000000001000;  { Clear instruction cache   }
+  CACRF_IBE           = %0000000000010000;  { Instruction burst enable  }
+  CACRF_EnableD       = %0000000100000000;  { 68030 Enable data cache   }
+  CACRF_FreezeD       = %0000001000000000;  { 68030 Freeze data cache   }
+  CACRF_ClearD        = %0000100000000000;  { 68030 Clear data cache    }
+  CACRF_DBE           = %0001000000000000;  { 68030 Data burst enable   }
+  CACRF_WriteAllocate = %0010000000000000;  { 68030 Write-Allocate mode
+                                              (must always be set!)     }
+  CACRF_EnableE       = 1073741824;  { Master enable for external caches }
+                                     { External caches should track the }
+                                     { state of the internal caches }
+                                     { such that they do not cache anything }
+                                     { that the internal cache turned off }
+                                     { for. }
+
+  CACRF_CopyBack      = $80000000;  { Master enable for copyback caches }
+
+  DMA_Continue        = 2;      { Continuation flag for CachePreDMA }
+  DMA_NoModify        = 4;      { Set if DMA does not update memory }
+  DMA_ReadFromRAM     = 8;      { Set if DMA goes *FROM* RAM to device }
+
+
+procedure AbortIO(io : pIORequest);
+procedure AddDevice(device : pDevice);
+procedure AddHead(list : pList;
+                  node : pNode);
+procedure AddIntServer(intNum : ULONG;
+                       Int : pInterrupt);
+procedure AddLibrary(lib : pLibrary);
+procedure AddMemHandler(memhand : pInterrupt);
+procedure AddMemList(size, attr : ULONG;
+                     pri : Longint;
+                     base : Pointer;
+                     name : STRPTR);
+procedure AddPort(port : pMsgPort);
+procedure AddResource(resource : Pointer);
+procedure AddSemaphore(sigsem : pSignalSemaphore);
+procedure AddTail(list : pList;
+                  node : pNode);
+procedure AddTask(task : pTask;
+                  initialPC, finalPC : Pointer);
+procedure Alert(alertNum : ULONG;
+                parameters : Pointer);
+function AllocAbs(bytesize : ULONG;
+                  location : Pointer) : Pointer;
+function Allocate(mem : pMemHeader;
+                  bytesize : ULONG) : Pointer;
+function AllocEntry(mem : pMemList) : pMemList;
+function AllocMem(bytesize : ULONG;
+                  reqs : ULONG) : Pointer;
+function AllocPooled( pooleheader : Pointer;
+                      memsize : ULONG ): Pointer;
+function AllocSignal(signalNum : Longint) : Shortint;
+function AllocTrap(trapNum : Longint) : Longint;
+function AllocVec( size, reqm : ULONG ): Pointer;
+function AttemptSemaphore(sigsem : pSignalSemaphore) : Boolean;
+function AttemptSemaphoreShared(sigsem : pSignalSemaphore): ULONG;
+function AvailMem(attr : ULONG) : ULONG;
+procedure CacheClearE( cxa : Pointer;
+                       lenght, caches : ULONG);
+procedure CacheClearU;
+function CacheControl( cachebits, cachemask: ULONG ): ULONG;
+procedure CachePostDMA(vaddress, length_IntPtr : Pointer;
+                        flags : ULONG );
+function CachePreDMA(vaddress, length_intPtr : Pointer;
+                     flags : ULONG): Pointer;
+procedure Cause(Int : pInterrupt);
+function CheckIO(io : pIORequest) : pIORequest;
+procedure ChildFree( tid : Pointer);
+procedure ChildOrphan( tid : Pointer);
+procedure ChildStatus( tid : Pointer);
+procedure ChildWait( tid : Pointer);
+procedure CloseDevice(io : pIORequest);
+procedure CloseLibrary(lib : pLibrary);
+procedure ColdReboot;
+procedure CopyMem(source, dest : Pointer;
+                  size : ULONG);
+procedure CopyMemQuick(source, dest : Pointer;
+                       size : ULONG);
+function CreateIORequest( mp : pMsgPort;
+                          size : ULONG ): pIORequest;
+function CreateMsgPort: pMsgPort;
+function CreatePool( requrements,puddlesize,
+                     puddletresh : ULONG ): Pointer;
+procedure Deallocate(header : pMemHeader;
+                     block : Pointer;
+                     size : ULONG);
+procedure Debug(Param : ULONG);
+procedure DeleteIORequest( iorq : Pointer );
+procedure DeleteMsgPort( mp : pMsgPort );
+procedure DeletePool( poolheader : Pointer );
+procedure Disable;
+function DoIO(io : pIORequest) : Shortint;
+procedure Enable;
+procedure Enqueue(list : pList;
+                  node : pNode);
+function FindName(start : pList;
+                  name : STRPTR) : pNode;
+function FindPort(name : STRPTR): pMsgPort;
+function FindResident(name : STRPTR) : pResident;
+function FindSemaphore(name : STRPTR) : pSignalSemaphore;
+function FindTask(name : STRPTR) : pTask;
+procedure Forbid;
+procedure FreeEntry(memList : pMemList);
+procedure ExecFreeMem(memBlock : Pointer;
+                  size : ULONG);
+procedure FreePooled( poolheader, memory: Pointer;
+                      memsize: ULONG);
+procedure FreeSignal(signalNum : Longint);
+procedure FreeTrap(signalNum : ULONG);
+procedure FreeVec( memory : Pointer );
+function GetCC : Word;
+function GetMsg(port : pMsgPort): pMessage;
+procedure InitCode(startClass, version : ULONG);
+procedure InitResident(resident : pResident;
+                       segList : ULONG);
+procedure InitSemaphore(sigsem : pSignalSemaphore);
+procedure InitStruct(table, memory : Pointer;
+                     size : ULONG);
+procedure Insert(list : pList;
+                 node, listNode : pNode);
+procedure MakeFunctions(target, functionarray : Pointer ;
+                       dispbase : ULONG);
+function MakeLibrary(vec, struct, init : Pointer;
+                     dSize : ULONG ;
+                     segList : Pointer) : pLibrary;
+function ObtainQuickVector(interruptCode : Pointer) : ULONG;
+procedure ObtainSemaphore(sigsem : pSignalSemaphore);
+procedure ObtainSemaphoreList(semlist : pList);
+procedure ObtainSemaphoreShared(sigsem : pSignalSemaphore);
+function OldOpenLibrary(lib : STRPTR): pLibrary;
+function OpenDevice(devName : STRPTR;
+                    unitNumber : ULONG;
+                    io : pIORequest; flags : ULONG) : Shortint;
+function OpenLibrary(libName : STRPTR;
+                     version : Integer) : pLibrary;
+function OpenResource(resname : STRPTR): Pointer;
+procedure Permit;
+function Procure(sem : pSemaphore;
+                 bid : pMessage) : Boolean;
+procedure PutMsg(port : pMsgPort;
+                 mess : pMessage);
+procedure RawDoFmt(Form : STRPTR;
+                   data, putChProc, putChData : Pointer);
+procedure ReleaseSemaphore(sigsem : pSignalSemaphore);
+procedure ReleaseSemaphoreList(siglist : pList);
+procedure RemDevice(device : pDevice);
+function RemHead(list : pList) : pNode;
+procedure RemIntServer(intNum : Longint;
+                       Int : pInterrupt);
+procedure RemLibrary(lib : pLibrary);
+procedure RemMemHandler(memhand : pInterrupt);
+procedure Remove(node : pNode);
+procedure RemPort(port : pMsgPort);
+procedure RemResource(resname : Pointer);
+procedure RemSemaphore(sigsem : pSignalSemaphore);
+function RemTail(list : pList) : pNode;
+procedure RemTask(task : pTask);
+procedure ReplyMsg(mess : pMessage);
+procedure SendIO(io : pIORequest);
+function SetExcept(newSignals, signalMask : ULONG) : ULONG;
+function SetFunction(lib : pLibrary;
+                     funcOff : LONG;
+                     funcEntry : Pointer) : Pointer;
+function SetIntVector(intNum : Longint;
+                      Int : pInterrupt) : pInterrupt;
+function SetSignal(newSignals, signalMask : ULONG) : ULONG;
+function SetSR(newSR, mask : ULONG) : ULONG;
+function SetTaskPri(task : pTask;
+                    priority : Longint) : Shortint;
+procedure Signal(task : pTask; signals : ULONG);
+procedure StackSwap( StackSwapRecord : Pointer );
+procedure SumKickData;
+procedure SumLibrary(lib : pLibrary);
+function SuperState : Pointer;
+function Supervisor(thefunc : Pointer): ULONG;
+function TypeOfMem(mem : Pointer) : ULONG;
+procedure UserState(s : Pointer);
+procedure Vacate(sigsem : pSignalSemaphore;
+                 bidMsg : pSemaphoreMessage);
+function Wait(signals : ULONG) : ULONG;
+function WaitIO(io : pIORequest) : Shortint;
+function WaitPort(port : pMsgPort): pMessage;
+
+{*  Exec support functions from amiga.lib  *}
+
+procedure BeginIO (ioRequest: pIORequest);
+function CreateExtIO (port: pMsgPort; size: Longint): pIORequest;
+procedure DeleteExtIO (ioReq: pIORequest);
+function CreateStdIO (port: pMsgPort): pIOStdReq;
+procedure DeleteStdIO (ioReq: pIOStdReq);
+function CreatePort (name: STRPTR; pri: integer): pMsgPort;
+procedure DeletePort (port: pMsgPort);
+function CreateTask (name: STRPTR; pri: longint; 
+                     initPC : Pointer;
+             stackSize : ULONG): pTask; 
+procedure DeleteTask (task: pTask);
+procedure NewList (list: pList);
+
+IMPLEMENTATION
+
+{*  Exec support functions from amiga.lib  *}
+
+procedure BeginIO (ioRequest: pIORequest); Assembler;
+asm
+    move.l  a6,-(a7)
+    move.l  ioRequest,a1    ; get IO Request
+    move.l  20(a1),a6      ; extract Device ptr
+    jsr     -30(a6)        ; call BEGINIO directly
+    move.l  (a7)+,a6
+end;
+
+function CreateExtIO (port: pMsgPort; size: Longint): pIORequest;
+var
+   IOReq: pIORequest;
+begin
+    IOReq := NIL;
+    if port <> NIL then
+    begin
+        IOReq := AllocMem(size, MEMF_CLEAR or MEMF_PUBLIC);
+        if IOReq <> NIL then
+        begin
+            IOReq^.io_Message.mn_Node.ln_Type   := NT_REPLYMSG;
+            IOReq^.io_Message.mn_Length    := size;
+            IOReq^.io_Message.mn_ReplyPort := port;
+        end;
+    end;
+    CreateExtIO := IOReq;
+end;
+
+
+procedure DeleteExtIO (ioReq: pIORequest);
+begin
+    if ioReq <> NIL then
+    begin
+        ioReq^.io_Message.mn_Node.ln_Type := $FF;
+        ioReq^.io_Message.mn_ReplyPort    := pMsgPort(-1);
+        ioReq^.io_Device                  := pDevice(-1);
+        ExecFreeMem(ioReq, ioReq^.io_Message.mn_Length);
+    end
+end;
+
+
+function CreateStdIO (port: pMsgPort): pIOStdReq;
+begin
+    CreateStdIO := pIOStdReq(CreateExtIO(port, sizeof(tIOStdReq)))
+end;
+
+
+procedure DeleteStdIO (ioReq: pIOStdReq);
+begin
+    DeleteExtIO(pIORequest(ioReq))
+end;
+
+
+function CreatePort (name: STRPTR; pri: integer): pMsgPort;
+var
+   port   : pMsgPort;
+   sigbit : shortint;
+begin
+    port  := NIL;
+    sigbit := AllocSignal(-1);
+    if sigbit <> -1 then
+    begin
+        port := AllocMem(sizeof(tMsgPort), MEMF_CLEAR or MEMF_PUBLIC);
+        if port = NIL then
+            FreeSignal(sigbit)
+        else
+            begin
+                port^.mp_Node.ln_Name  := name;
+                port^.mp_Node.ln_Pri   := pri;
+                port^.mp_Node.ln_Type  := NT_MSGPORT;
+
+                port^.mp_Flags    := PA_SIGNAL;
+                port^.mp_SigBit   := sigbit;
+                port^.mp_SigTask  := FindTask(NIL);
+
+                if name <> NIL then
+                    AddPort(port)
+                else
+                    NewList(@port^.mp_MsgList);
+            end;
+    end;
+    CreatePort := port;
+end;
+
+
+procedure DeletePort (port: pMsgPort);
+begin
+    if port <> NIL then
+    begin
+        if port^.mp_Node.ln_Name <> NIL then
+            RemPort(port);
+
+        port^.mp_SigTask       := pTask(-1);
+        port^.mp_MsgList.lh_Head  := pNode(-1);
+        FreeSignal(port^.mp_SigBit);
+        ExecFreeMem(port, sizeof(tMsgPort));
+    end;
+end;
+
+
+function CreateTask (name: STRPTR; pri: longint;
+        initPC: pointer; stackSize: ULONG): pTask;
+var
+   memlist : pMemList;
+   task    : pTask;
+   totalsize : Longint;
+begin
+    task  := NIL;
+    stackSize   := (stackSize + 3) and not 3;
+    totalsize := sizeof(tMemList) + sizeof(tTask) + stackSize;
+
+    memlist := AllocMem(totalsize, MEMF_PUBLIC + MEMF_CLEAR);
+    if memlist <> NIL then begin
+       memlist^.ml_NumEntries := 1;
+       memlist^.ml_ME[0].me_Un.meu_Addr := Pointer(memlist + 1);
+       memlist^.ml_ME[0].me_Length := totalsize - sizeof(tMemList);
+
+       task := pTask(memlist + sizeof(tMemList) + stackSize);
+       task^.tc_Node.ln_Pri := pri;
+       task^.tc_Node.ln_Type := NT_TASK;
+       task^.tc_Node.ln_Name := name;
+       task^.tc_SPLower := Pointer(memlist + sizeof(tMemList));
+       task^.tc_SPUpper := Pointer(task^.tc_SPLower + stackSize);
+       task^.tc_SPReg := task^.tc_SPUpper;
+
+       NewList(@task^.tc_MemEntry);
+       AddTail(@task^.tc_MemEntry,@memlist^.ml_Node);
+
+       AddTask(task,initPC,NIL) 
+    end;
+    CreateTask := task;
+end;
+
+
+procedure DeleteTask (task: pTask);
+begin
+    RemTask(task)
+end;
+
+
+procedure NewList (list: pList);
+begin
+    with list^ do
+    begin
+        lh_Head     := pNode(@lh_Tail);
+        lh_Tail     := NIL;
+        lh_TailPred := pNode(@lh_Head)
+    end
+end;
+
+
+
+procedure AbortIO(io : pIORequest); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  io,a1
+    JSR -480(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure AddDevice(device : pDevice); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  device,a1
+    JSR -432(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure AddHead(list : pList;
+                  node : pNode); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  list,a0
+    MOVE.L  node,a1
+    JSR -240(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure AddIntServer(intNum : ULONG;
+                       Int : pInterrupt); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  intNum,d0
+    MOVE.L  Int,a1
+    JSR -168(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure AddLibrary(lib : pLibrary); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  lib,a1
+    JSR -396(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure AddMemHandler(memhand : pInterrupt); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  memhand,a1
+    JSR -774(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure AddMemList(size, attr : ULONG;
+                     pri : Longint;
+                     base : Pointer;
+                     name : STRPTR); Assembler;
+asm
+    MOVEM.L d2/a6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  size,d0
+    MOVE.L  attr,d1
+    MOVE.L  pri,d2
+    MOVE.L  base,a0
+    MOVE.L  name,a1
+    JSR -618(A6)
+    MOVEM.L (A7)+,d2/a6
+end;
+
+procedure AddPort(port : pMsgPort); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  port,a1
+    JSR -354(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure AddResource(resource : Pointer); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  resource,a1
+    JSR -486(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure AddSemaphore(sigsem : pSignalSemaphore); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  sigsem,a1
+    JSR -600(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure AddTail(list : pList;
+                  node : pNode); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  list,a0
+    MOVE.L  node,a1
+    JSR -246(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure AddTask(task : pTask;
+                  initialPC, finalPC : Pointer); Assembler;
+asm
+    MOVEM.L a2/a3/a6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  task,a1
+    MOVE.L  initialPC,a2
+    MOVE.L  finalPC,a3
+    JSR -282(A6)
+    MOVEM.L (A7)+,a2/a3/a6
+end;
+
+procedure Alert(alertNum : ULONG;
+                parameters : Pointer); Assembler;
+asm
+    MOVEM.L d7/a6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  alertNum,d7
+    JSR -108(A6)
+    MOVEM.L (A7)+,d7/a6
+end;
+
+function AllocAbs(bytesize : ULONG;
+                  location : Pointer) : Pointer; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  bytesize,d0
+    MOVE.L  location,a1
+    JSR -204(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function Allocate(mem : pMemHeader;
+                  bytesize : ULONG) : Pointer; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  mem,a0
+    MOVE.L  bytesize,d0
+    JSR -186(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function AllocEntry(mem : pMemList) : pMemList; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  mem,a0
+    JSR -222(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function AllocMem(bytesize : ULONG;
+                  reqs : ULONG) : Pointer; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  bytesize,d0
+    MOVE.L  reqs,d1
+    JSR -198(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function AllocPooled( pooleheader : Pointer;
+                      memsize : ULONG ): Pointer; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  pooleheader,a0
+    MOVE.L  memsize,d0
+    JSR -708(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function AllocSignal(signalNum : Longint) : Shortint; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  signalNum,d0
+    JSR -330(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function AllocTrap(trapNum : Longint) : Longint; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  trapNum,d0
+    JSR -342(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function AllocVec( size, reqm : ULONG ): Pointer; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  size,d0
+    MOVE.L  reqm,d1
+    JSR -684(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function AttemptSemaphore(sigsem : pSignalSemaphore) : Boolean; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  sigsem,a0
+    JSR -576(A6)
+    MOVE.L  (A7)+,A6
+    TST.L   d0
+    SNE     d0
+    NEG.B   d0
+end;
+
+function AttemptSemaphoreShared(sigsem : pSignalSemaphore): ULONG; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  sigsem,a0
+    JSR -720(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function AvailMem(attr : ULONG) : ULONG; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  attr,d1
+    JSR -216(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure CacheClearE( cxa : Pointer;
+                       lenght, caches : ULONG); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  cxa,a0
+    MOVE.L  lenght,d0
+    MOVE.L  caches,d1
+    JSR -642(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure CacheClearU; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    JSR -636(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function CacheControl( cachebits, cachemask: ULONG ): ULONG; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  cachebits,d0
+    MOVE.L  cachemask,d1
+    JSR -648(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure CachePostDMA(vaddress, length_IntPtr : Pointer;
+                        flags : ULONG ); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  vaddress,a0
+    MOVE.L  length_IntPtr,a1
+    MOVE.L  flags,d0
+    JSR -768(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function CachePreDMA(vaddress, length_intPtr : Pointer;
+                     flags : ULONG): Pointer; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  vaddress,a0
+    MOVE.L  length_intPtr,a1
+    MOVE.L  flags,d0
+    JSR -762(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure Cause(Int : pInterrupt); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  Int,a1
+    JSR -180(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function CheckIO(io : pIORequest) : pIORequest; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  io,a1
+    JSR -468(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure ChildFree( tid : Pointer); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  tid,d0
+    JSR -738(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure ChildOrphan( tid : Pointer); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  tid,d0
+    JSR -744(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure ChildStatus( tid : Pointer); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  tid,d0
+    JSR -750(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure ChildWait( tid : Pointer); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  tid,d0
+    JSR -756(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure CloseDevice(io : pIORequest); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  io,a1
+    JSR -450(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure CloseLibrary(lib : pLibrary); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  lib,a1
+    JSR -414(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure ColdReboot; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    JSR -726(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure CopyMem(source, dest : Pointer;
+                  size : ULONG); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  source,a0
+    MOVE.L  dest,a1
+    MOVE.L  size,d0
+    JSR -624(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure CopyMemQuick(source, dest : Pointer;
+                       size : ULONG); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  source,a0
+    MOVE.L  dest,a1
+    MOVE.L  size,d0
+    JSR -630(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function CreateIORequest( mp : pMsgPort;
+                          size : ULONG ): pIORequest; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  mp,a0
+    MOVE.L  size,d0
+    JSR -654(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function CreateMsgPort: pMsgPort; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    JSR -666(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function CreatePool( requrements,puddlesize,
+                     puddletresh : ULONG ): Pointer; Assembler;
+asm
+    MOVEM.L d2/a6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  requrements,d0
+    MOVE.L  puddlesize,d1
+    MOVE.L  puddletresh,d2
+    JSR -696(A6)
+    MOVEM.L (A7)+,d2/a6
+end;
+
+procedure Deallocate(header : pMemHeader;
+                     block : Pointer;
+                     size : ULONG); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  header,a0
+    MOVE.L  block,a1
+    MOVE.L  size,d0
+    JSR -192(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure Debug(Param : ULONG); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  Param,d0
+    JSR -114(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure DeleteIORequest( iorq : Pointer ); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  iorq,a0
+    JSR -660(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure DeleteMsgPort( mp : pMsgPort ); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  mp,a0
+    JSR -672(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure DeletePool( poolheader : Pointer ); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  poolheader,a0
+    JSR -702(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure Disable; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    JSR -120(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function DoIO(io : pIORequest) : Shortint; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  io,a1
+    JSR -456(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure Enable; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    JSR -126(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure Enqueue(list : pList;
+                  node : pNode); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  list,a0
+    MOVE.L  node,a1
+    JSR -270(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function FindName(start : pList;
+                  name : STRPTR) : pNode; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  start,a0
+    MOVE.L  name,a1
+    JSR -276(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function FindPort(name : STRPTR): pMsgPort; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  name,a1
+    JSR -390(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function FindResident(name : STRPTR) : pResident; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  name,a1
+    JSR -96(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function FindSemaphore(name : STRPTR) : pSignalSemaphore; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  name,a1
+    JSR -594(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function FindTask(name : STRPTR) : pTask; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  name,a1
+    JSR -294(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure Forbid; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    JSR -132(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure FreeEntry(memList : pMemList); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  memlist,a0
+    JSR -228(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure ExecFreeMem(memBlock : Pointer;
+                  size : ULONG); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  memBlock,a1
+    MOVE.L  size,d0
+    JSR -210(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure FreePooled( poolheader, memory: Pointer;
+                      memsize: ULONG); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  poolheader,a0
+    MOVE.L  memory,a1
+    MOVE.L  memsize,d0
+    JSR -714(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure FreeSignal(signalNum : Longint); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  signalNum,d0
+    JSR -336(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure FreeTrap(signalNum : ULONG); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  signalNum,d0
+    JSR -348(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure FreeVec( memory : Pointer ); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  memory,a1
+    JSR -690(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function GetCC : Word; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    JSR -528(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function GetMsg(port : pMsgPort): pMessage; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  port,a0
+    JSR -372(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure InitCode(startClass, version : ULONG); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  startClass,d0
+    MOVE.L  version,d1
+    JSR -72(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure InitResident(resident : pResident;
+                       segList : ULONG); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  resident,a1
+    MOVE.L  seglist,d1
+    JSR -102(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure InitSemaphore(sigsem : pSignalSemaphore); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  sigsem,a0
+    JSR -558(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure InitStruct(table, memory : Pointer;
+                     size : ULONG); Assembler;
+asm
+    MOVEM.L a2/a6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  table,a1
+    MOVE.L  memory,a2
+    MOVE.L  size,d0
+    JSR -78(A6)
+    MOVEM.L (A7)+,a2/a6
+end;
+
+procedure Insert(list : pList;
+                 node, listNode : pNode); Assembler;
+asm
+    MOVEM.L a2/a6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  list,a0
+    MOVE.L  node,a1
+    MOVE.L  listNode,a2
+    JSR -234(A6)
+    MOVEM.L (A7)+,a2/a6
+end;
+
+procedure MakeFunctions(target, functionarray : Pointer ;
+                       dispbase : ULONG); Assembler;
+asm
+    MOVEM.L a2/a6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  target,a0
+    MOVE.L  functionarray,a1
+    MOVE.L  dispbase,a2
+    JSR -90(A6)
+    MOVEM.L (A7)+,a2/a6
+end;
+
+function MakeLibrary(vec, struct, init : Pointer;
+                     dSize : ULONG ;
+                     segList : Pointer) : pLibrary; Assembler;
+asm
+    MOVEM.L a2/a6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  vec,a0
+    MOVE.L  struct,a1
+    MOVE.L  init,a2
+    MOVE.L  dSize,d0
+    MOVE.L  seglist,d1
+    JSR -84(A6)
+    MOVEM.L (A7)+,a2/a6
+end;
+
+function ObtainQuickVector(interruptCode : Pointer) : ULONG; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  interruptCode,a0
+    JSR -786(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure ObtainSemaphore(sigsem : pSignalSemaphore); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  sigsem,a0
+    JSR -564(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure ObtainSemaphoreList(semlist : pList); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  semlist,a0
+    JSR -582(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure ObtainSemaphoreShared(sigsem : pSignalSemaphore); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  sigsem,a0
+    JSR -678(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function OldOpenLibrary(lib : STRPTR): pLibrary; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  lib,a1
+    JSR -408(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function OpenDevice(devName : STRPTR;
+                    unitNumber : ULONG;
+                    io : pIORequest; flags : ULONG) : Shortint; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  devName,a0
+    MOVE.L  unitNumber,d0
+    MOVE.L  io,a1
+    MOVE.L  flags,d1
+    JSR -444(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function OpenLibrary(libName : STRPTR;
+                     version : Integer) : pLibrary; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  libName,a1
+    MOVE.L  version,d0
+    JSR -552(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function OpenResource(resname : STRPTR): Pointer; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  resname,a1
+    JSR -498(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure Permit; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    JSR -138(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function Procure(sem : pSemaphore;
+                 bid : pMessage) : Boolean; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  sem,a0
+    MOVE.L  bid,a1
+    JSR -540(A6)
+    MOVE.L  (A7)+,A6
+    TST.L   d0
+    SNE     d0
+    NEG.B   d0
+end;
+
+procedure PutMsg(port : pMsgPort;
+                 mess : pMessage); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  port,a0
+    MOVE.L  mess,a1
+    JSR -366(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure RawDoFmt(Form : STRPTR;
+                   data, putChProc, putChData : Pointer); Assembler;
+asm
+    MOVEM.L a2/a3/a6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  Form,a0
+    MOVE.L  data,a1
+    MOVE.L  putChProc,a2
+    MOVE.L  putChData,a3
+    JSR -522(A6)
+    MOVEM.L (A7)+,a2/a3/a6
+end;
+
+procedure ReleaseSemaphore(sigsem : pSignalSemaphore); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  sigsem,a0
+    JSR -570(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure ReleaseSemaphoreList(siglist : pList); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  siglist,a0
+    JSR -588(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure RemDevice(device : pDevice); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  device,a1
+    JSR -438(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function RemHead(list : pList) : pNode; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  list,a0
+    JSR -258(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure RemIntServer(intNum : Longint;
+                       Int : pInterrupt); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  intNum,d0
+    MOVE.L  Int,a1
+    JSR -174(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure RemLibrary(lib : pLibrary); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  lib,a1
+    JSR -402(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure RemMemHandler(memhand : pInterrupt); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  memhand,a1
+    JSR -780(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure Remove(node : pNode); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  node,a1
+    JSR -252(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure RemPort(port : pMsgPort); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  port,a1
+    JSR -360(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure RemResource(resname : Pointer); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  resname,a1
+    JSR -492(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure RemSemaphore(sigsem : pSignalSemaphore); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  sigsem,a1
+    JSR -606(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function RemTail(list : pList) : pNode; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  list,a0
+    JSR -264(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure RemTask(task : pTask); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  task,a1
+    JSR -288(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure ReplyMsg(mess : pMessage); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  mess,a1
+    JSR -378(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure SendIO(io : pIORequest); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  io,a1
+    JSR -462(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function SetExcept(newSignals, signalMask : ULONG) : ULONG; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  newSignals,d0
+    MOVE.L  signalMask,d1
+    JSR -312(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function SetFunction(lib : pLibrary;
+                     funcOff : LONG;
+                     funcEntry : Pointer) : Pointer; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  lib,a1
+    MOVE.L  funcOff,a0
+    MOVE.L  funcEntry,d0
+    JSR -420(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function SetIntVector(intNum : Longint;
+                      Int : pInterrupt) : pInterrupt; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  intNum,d0
+    MOVE.L  Int,a1
+    JSR -162(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function SetSignal(newSignals, signalMask : ULONG) : ULONG; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  newSignals,d0
+    MOVE.L  signalMask,d1
+    JSR -306(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function SetSR(newSR, mask : ULONG) : ULONG; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  newSR,d0
+    MOVE.L  mask,d1
+    JSR -144(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function SetTaskPri(task : pTask;
+                    priority : Longint) : Shortint; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  task,a1
+    MOVE.L  priority,d0
+    JSR -300(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure Signal(task : pTask; signals : ULONG); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  task,a1
+    MOVE.L  signals,d0
+    JSR -324(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure StackSwap( StackSwapRecord : Pointer ); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  StackSwapRecord,a0
+    JSR -732(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure SumKickData; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    JSR -612(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure SumLibrary(lib : pLibrary); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  lib,a1
+    JSR -426(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function SuperState : Pointer; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    JSR -150(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function Supervisor(thefunc : Pointer): ULONG; Assembler;
+asm
+    MOVEM.L a5/a6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  thefunc,a5
+    JSR -30(A6)
+    MOVEM.L (A7)+,a5/a6
+end;
+
+function TypeOfMem(mem : Pointer) : ULONG; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  mem,a1
+    JSR -534(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure UserState(s : Pointer); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  s,d0
+    JSR -156(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+procedure Vacate(sigsem : pSignalSemaphore;
+                 bidMsg : pSemaphoreMessage); Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  sigsem,a0
+    MOVE.L  bidMsg,a1
+    JSR -546(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function Wait(signals : ULONG) : ULONG; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  signals,d0
+    JSR -318(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function WaitIO(io : pIORequest) : Shortint; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  io,a1
+    JSR -474(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+function WaitPort(port : pMsgPort): pMessage; Assembler;
+asm
+    MOVE.L  A6,-(A7)
+    MOVE.L  _ExecBase,A6
+    MOVE.L  port,a0
+    JSR -384(A6)
+    MOVE.L  (A7)+,A6
+end;
+
+
+end.
+
+
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:47  root
+  Initial revision
+
+  Revision 1.3  1998/01/26 12:02:42  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/amiga/exec.pp
+  description:
+  ----------------------------
+  revision 1.2
+  date: 1997/12/14 19:02:47;  author: carl;  state: Exp;  lines: +11 -10
+  * small bugfixes
+  ----------------------------
+  revision 1.1
+  date: 1997/12/10 13:48:45;  author: carl;  state: Exp;
+  + exec dynamic library definitions and calls.
+  =============================================================================
+}

rtl/amiga/os.inc

@@ -0,0 +1,42 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+{$define amiga}
+{$undef go32v2}
+{$undef os2}
+{$undef linux}
+{$undef win32}
+{$undef macos}
+{$undef atari}
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:47  root
+  Initial revision
+
+  Revision 1.3  1998/01/30 13:22:24  carl
+   - undef amiga!
+
+  Revision 1.2  1998/01/26 12:02:47  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/amiga/os.inc
+  description:
+  ----------------------------
+  revision 1.1
+  date: 1998/01/24 05:11:03;  author: carl;  state: Exp;
+    + initial revision
+  =============================================================================
+}

rtl/amiga/prt0.as

@@ -0,0 +1,45 @@
+
+   .text
+
+   .align 4
+
+   .globl _start
+   .globl start
+_start:
+start:
+|	Save stack pointer for exit() routine
+
+	movel	   sp,STKPTR	| save stack pointer
+	addl	   #4,STKPTR	| account for this jsr to get to original
+
+|	Save the command line pointer to CommandLine
+
+    movel	a0,__ARGS
+    beq    .Ldont_nullit
+
+	 moveb  #0,a0@(0,d0:w)	   | null terminate it
+ .Ldont_nullit:
+
+    jsr PASCALMAIN
+
+    movel  STKPTR,sp
+    rts
+
+    .data
+
+    .align 4
+
+    .globl __ARGS
+ __ARGS:                   | pointer to the arguments
+      .long 0
+    .globl  __ARGC
+ __ARGC:                    | number of arguments
+      .word 0
+    .globl STKPTR          | Used to terminate the program, initial SP
+ STKPTR:
+      .long 0
+
+
+
+
+

rtl/amiga/readme

@@ -0,0 +1,4 @@
+For the moment there is no makefile for the amiga system unit, therefore 
+to compile you must copy all files from the inc and m68k directories into 
+the same directory as the files here.
+

rtl/amiga/sysamiga.pas

@@ -0,0 +1,759 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by the Free Pascal development team.
+    Some parts taken from
+       Marcel Timmermans - Modula 2 Compiler
+       Nils Sjoholm - Amiga porter
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+unit sysamiga;
+
+{ Things left to do :                                          }
+{   - Fix randomize                                            }
+{   - Fix DOSError result variable to conform to IOResult of   }
+{      Turbo Pascal                                            }
+
+{$I os.inc}
+
+  interface
+
+    { used for single computations }
+    const BIAS4 = $7f-1;
+
+    {$I systemh.inc}
+
+    {$I heaph.inc}
+
+const
+  UnusedHandle    : longint = -1; 
+  StdInputHandle  : longint = 0;
+  StdOutputHandle : longint = 0;
+  StdErrorHandle  : longint = 0; 
+
+ _ExecBase:longint = $4;
+ _WorkbenchMsg : longint = 0;
+ intuitionname : pchar = 'intuition.library';
+ dosname : pchar = 'dos.library';
+ utilityname : pchar = 'utility.library';
+
+ _IntuitionBase : pointer = nil;       { intuition library pointer }
+ _DosBase       : pointer = nil;       { DOS library pointer       }
+ _UtilityBase   : pointer = nil;       { utiity library pointer    }
+
+ _LVOFindTask          = -294;
+ _LVOWaitPort          = -384;
+ _LVOGetMsg            = -372;
+ _LVOOpenLibrary       = -552;
+ _LVOCloseLibrary      = -414;
+ _LVOClose             = -36;
+ _LVOOpen              = -30;
+ _LVOIoErr             = -132;
+ _LVOSeek              = -66;
+ _LVODeleteFile        = -72;
+ _LVORename            = -78;
+ _LVOWrite             = -48;
+ _LVORead              = -42;
+ _LVOCreateDir         = -120;
+ _LVOSetCurrentDirName = -558;
+ _LVOGetCurrentDirName = -564;
+ _LVOInput             = -54;
+ _LVOOutput            = -60;
+
+
+  implementation
+
+    {$I system.inc}
+    {$I lowmath.inc}
+
+    type
+       plongint = ^longint;
+
+
+{$S-}
+    PROCEDURE St1(stack_size: longint);[public,alias: 'STACKCHECK'];
+    begin
+     asm
+         { called when trying to get local stack }
+         { if the compiler directive $S is set   }
+         { it must preserve all registers !!     }
+        ADD.L   A7,D0     {  stacksize + actual stackpointer }
+        MOVE.L  _ExecBase,A0
+        MOVE.L  276(A0),A0       { ExecBase.thisTask }
+        CMP.L   58(A0),D0        { Task.SpLower      }
+        BGT     @Ok
+        move.l  #202,d0
+        jsr     HALT_ERROR       { stack overflow    }
+    @Ok:
+     end;
+   end;
+
+
+    procedure CloseLibrary(lib : pointer); Assembler;
+    {  Close the library pointed to in lib }
+    asm
+      MOVE.L  A6,-(A7)
+      MOVE.L  _ExecBase,A6
+      MOVE.L  lib,a1
+      JSR     _LVOCloseLibrary(A6)
+      MOVE.L  (A7)+,A6
+   end;
+
+
+   Function KickVersion: word; assembler;
+   asm
+     move.l  _ExecBase, a0       { Get Exec Base                           }
+     move.l  20(a0), d0          { Return version - version at this offset }
+   end;
+
+    procedure halt(errnum : byte);
+      begin
+         do_exit;
+         flush(stderr);
+         { close the libraries }
+         If _UtilityBase <> nil then
+         Begin
+           CloseLibrary(_UtilityBase);
+         end;
+         If _DosBase <> nil then
+         Begin
+           CloseLibrary(_DosBase);
+         end;
+         If _IntuitionBase <> nil then
+         Begin
+           CloseLibrary(_IntuitionBase);
+         end;
+         asm
+            clr.l   d0
+            move.b  errnum,d0
+            move.l  STKPTR,sp
+            rts
+         end;
+      end;
+
+    function paramcount : longint; assembler;
+    asm
+            clr.l   d0
+            move.w  __ARGC,d0
+            sub.w   #1,d0
+    end;
+
+    function paramstr(l : longint) : string;
+
+      function args : pointer; assembler;
+      asm
+         move.l __ARGS,d0
+      end;
+
+      var
+         p : ^pchar;
+
+      begin
+         if (l>=0) and (l<=paramcount) then
+           begin
+              p:=args;
+              paramstr:=strpas(p[l]);
+           end
+         else paramstr:='';
+      end;
+
+    procedure randomize;
+
+      var
+         hl : longint;
+
+      begin
+         asm
+           { !!!!!!! }
+         end;
+         randseed:=hl;
+      end;
+
+  { This routine is used to grow the heap.  }
+  { But here we do a trick, we say that the }
+  { heap cannot be regrown!                 }
+  function sbrk( size: longint): longint;
+  { on exit -1 = if fails.               }
+  Begin
+   sbrk:=-1;
+  end;
+
+
+
+{$I heap.inc}
+
+
+{****************************************************************************
+                          Low Level File Routines
+ ****************************************************************************}
+
+procedure do_close(h : longint);
+begin
+  asm
+            move.l  h,d1
+            move.l  a6,d6              { save a6 }
+            move.l  _DOSBase,a6
+            jsr     _LVOClose(a6)
+            move.l  d6,a6              { restore a6 }
+  end;
+end;
+
+
+procedure do_erase(p : pchar);
+begin
+  asm
+           move.l  a6,d6               { save a6 }
+
+           move.l  _DOSBase,a6
+           move.l  p,d1
+           jsr     _LVODeleteFile(a6)
+           tst.l   d0                  { zero = failure }
+           bne     @noerror
+
+           jsr     _LVOIoErr(a6)
+           move.l  d0,InOutRes
+
+         @noerror:
+           move.l  d6,a6               { restore a6 }
+  end;
+end;
+
+
+procedure do_rename(p1,p2 : pchar);
+begin
+  asm
+           move.l  a6,d6                  { save a6 }
+           move.l  d2,-(sp)               { save d2 }
+
+           move.l  p1,d1
+           move.l  p2,d2
+           move.l  _DOSBase,a6
+           jsr     _LVORename(a6)
+           move.l  (sp)+,d2               { restore d2 }
+           tst.l   d0
+           bne     @dosreend              { if zero = error }
+           jsr     _LVOIoErr(a6)
+           move.l  d0,InOutRes
+         @dosreend:
+           move.l  d6,a6                  { restore a6 }
+  end;
+end;
+
+
+function do_write(h,addr,len : longint) : longint;
+begin
+  asm
+            move.l  a6,d6
+
+            movem.l d2/d3,-(sp)
+            move.l  _DOSBase,a6
+            move.l  h,d1
+            move.l  addr,d2
+            move.l  len,d3
+            jsr     _LVOWrite(a6)
+            movem.l (sp)+,d2/d3
+
+            tst.l   d0
+            bne     @doswrend              { if zero = error }
+            jsr     _LVOIoErr(a6)
+            move.l  d0,InOutRes
+            bra     @doswrend2
+          @doswrend:
+            move.l  d0,@RESULT
+          @doswrend2:
+            move.l  d6,a6
+  end;
+end;
+
+
+function do_read(h,addr,len : longint) : longint;
+begin
+  asm
+            move.l  a6,d6
+
+            movem.l d2/d3,-(sp)
+            move.l  _DOSBase,a6
+            move.l  h,d1
+            move.l  addr,d2
+            move.l  len,d3
+            jsr     _LVORead(a6)
+            movem.l (sp)+,d2/d3
+
+            tst.l   d0
+            bne     @doswrend              { if zero = error }
+            jsr     _LVOIoErr(a6)
+            move.l  d0,InOutRes
+            bra     @doswrend2
+          @doswrend:
+            move.l  d0,@RESULT
+          @doswrend2:
+            move.l  d6,a6
+  end;
+end;
+
+
+function do_filepos(handle : longint) : longint;
+begin
+  asm
+             move.l  a6,d6
+
+             move.l  handle,d1
+             move.l  d2,-(sp)
+             move.l  d3,-(sp)              { save registers              }
+
+             clr.l   d2                    { offset 0 }
+             move.l  #0,d3                 { OFFSET_CURRENT }
+             jsr    _LVOSeek(a6)
+
+             move.l  (sp)+,d3              { restore registers }
+             move.l  (sp)+,d2
+             cmp.l   #-1,d0                { is there a file access error? }
+             bne     @noerr
+             jsr     _LVOIoErr(a6)
+             move.l  d0,InOutRes
+             bra     @fposend
+      @noerr:
+             move.l  d0,@Result
+      @fposend:
+             move.l  d6,a6                 { restore a6 }
+  end;
+end;
+
+
+procedure do_seek(handle,pos : longint);
+begin
+  asm
+             move.l  a6,d6
+
+             move.l  handle,d1
+             move.l  d2,-(sp)
+             move.l  d3,-(sp)              { save registers              }
+
+             move.l  pos,d2
+             move.l  #-1,d3                 { OFFSET_BEGINNING }
+             jsr    _LVOSeek(a6)
+
+             move.l  (sp)+,d3              { restore registers }
+             move.l  (sp)+,d2
+             cmp.l   #-1,d0                { is there a file access error? }
+             bne     @noerr
+             jsr     _LVOIoErr(a6)
+             move.l  d0,InOutRes
+             bra     @seekend
+      @noerr:
+      @seekend:
+             move.l  d6,a6                 { restore a6 }
+  end;
+end;
+
+
+function do_seekend(handle:longint):longint;
+begin
+  asm
+             { seek from end of file }
+             move.l  a6,d6
+
+             move.l  handle,d1
+             move.l  d2,-(sp)
+             move.l  d3,-(sp)              { save registers              }
+
+             clr.l   d2
+             move.l  #1,d3                 { OFFSET_END }
+             jsr    _LVOSeek(a6)
+
+             move.l  (sp)+,d3              { restore registers }
+             move.l  (sp)+,d2
+             cmp.l   #-1,d0                { is there a file access error? }
+             bne     @noerr
+             jsr     _LVOIoErr(a6)
+             move.l  d0,InOutRes
+             bra     @seekend
+      @noerr:
+             move.l  d0,@Result
+      @seekend:
+             move.l  d6,a6                 { restore a6 }
+  end;
+end;
+
+
+function do_filesize(handle : longint) : longint;
+var
+  aktfilepos : longint;
+begin
+   aktfilepos:=do_filepos(handle);
+   do_filesize:=do_seekend(handle);
+   do_seek(handle,aktfilepos);
+end;
+
+
+procedure do_truncate (handle,pos:longint);
+begin
+  {!!!!!!!!!!!!}
+end;
+
+
+procedure do_open(var f;p:pchar;flags:longint);
+{
+  filerec and textrec have both handle and mode as the first items so
+  they could use the same routine for opening/creating.
+  when (flags and $10)   the file will be append
+  when (flags and $100)  the file will be truncate/rewritten
+  when (flags and $1000) there is no check for close (needed for textfiles)
+}
+var
+  i : longint;
+  oflags: longint;
+begin
+ { close first if opened }
+  if ((flags and $1000)=0) then
+   begin
+     case filerec(f).mode of
+      fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
+      fmclosed : ;
+     else
+      begin
+        inoutres:=102; {not assigned}
+        exit;
+      end;
+     end;
+   end;
+{ reset file handle }
+  filerec(f).handle:=UnusedHandle;
+  oflags:=$04;
+{ convert filemode to filerec modes }
+  case (flags and 3) of
+   0 : begin
+         filerec(f).mode:=fminput;
+         oflags:=$01;
+       end;
+   1 : filerec(f).mode:=fmoutput;
+   2 : filerec(f).mode:=fminout;
+  end;
+  if (flags and $100)<>0 then
+   begin
+     filerec(f).mode:=fmoutput;
+     oflags:=$02;
+   end
+  else
+   if (flags and $10)<>0 then
+    begin
+      filerec(f).mode:=fmoutput;
+      oflags:=$04;
+    end;
+{ empty name is special }
+  if p[0]=#0 then
+   begin
+     case filerec(f).mode of
+       fminput : filerec(f).handle:=StdInputHandle;
+      fmappend,
+      fmoutput : begin
+                   filerec(f).handle:=StdOutputHandle;
+                   filerec(f).mode:=fmoutput; {fool fmappend}
+                 end;
+     end;
+     exit;
+   end;
+    { THE AMIGA AUTOMATICALLY OPENS IN READ-WRITE MODE }
+    { FOR ALL CASES.                                   }
+         asm
+             move.l  a6,d6                  { save a6 }
+
+             move.l  f,d1
+             move.l  #1004,d0               { MODE_READWRITE }
+             move.l  _DOSBase,a6
+             jsr     _LVOOpen(a6)
+             tst.l   d0
+             bne     @noopenerror           { on zero an error occured }
+             jsr     _LVOIoErr(a6)
+             move.l  d0,InOutRes
+             bra     @openend
+          @noopenerror:
+             move.l  d0,i
+          @openend:
+
+             move.l  d6,a6                 { restore a6 }
+         end;
+    filerec(f).handle:=i;
+    if (flags and $10)<>0 then
+       do_seekend(filerec(f).handle);
+end;
+
+{*****************************************************************************
+                           UnTyped File Handling
+*****************************************************************************}
+
+{$i file.inc}
+
+{*****************************************************************************
+                           Typed File Handling
+*****************************************************************************}
+
+{$i typefile.inc}
+
+{*****************************************************************************
+                           Text File Handling
+*****************************************************************************}
+
+{$i text.inc}
+
+{*****************************************************************************
+                           Directory Handling
+*****************************************************************************}
+      
+procedure mkdir(const s : string);
+var
+  buffer : array[0..255] of char;
+begin
+  move(s[1],buffer,length(s));
+  buffer[length(s)]:=#0;
+  asm
+        move.l  a6,d6
+        move.l  _DosBase,a6
+        lea     buffer,a0
+        move.l  a0,d1
+        jsr     _LVOCreateDir(a6)
+        tst.l   d0
+        bne     @noerror
+        move.l  #1,InOutRes
+@noerror:
+        move.l  d6,a6
+  end;
+end;
+
+
+procedure rmdir(const s : string);
+var
+  buffer : array[0..255] of char;
+begin
+  move(s[1],buffer,length(s));
+  buffer[length(s)]:=#0;
+  do_erase(buffer);
+end;
+  
+
+procedure chdir(const s : string);
+var
+  buffer : array[0..255] of char;
+begin
+  move(s[1],buffer,length(s));
+  buffer[length(s)]:=#0;
+  asm
+        move.l  a6,d6
+        move.l  _DosBase,a6
+        lea     buffer,a1
+        move.l  a1,d1
+        jsr     _LVOSetCurrentDirName(a6)
+        bne     @noerror
+        move.l  #1,InOutRes
+@noerror:
+        move.l  d6,a6
+  end;
+end;
+
+
+procedure getdir(drivenr : byte;var dir : string);
+var
+  l : longint;
+  p : pointer;
+begin
+  l:=length(dir);
+  if drivenr <> 0 then
+   begin
+     dir:='';
+     exit;
+   end;
+  p:=@dir[1];
+  if l <> 0 then         { workaround for v36 bug }
+   Begin
+     asm
+        move.l  a6,d6
+        move.l  _DosBase,a6
+        move.l  p,d1
+        move.l  l,d2
+        jsr     _LVOGetCurrentDirName(a6)
+        bne     @noerror
+        move.l  #1,InOutRes
+      @noerror:
+        move.l  d6,a6
+     end;
+   end
+  else
+   dir:='';
+{ upcase the string (FPKPascal function) }
+  dir:=upcase(dir);
+end;
+
+        
+{*****************************************************************************
+                         SystemUnit Initialization
+*****************************************************************************}
+
+Procedure Startup; Assembler;
+asm
+    move.l  a6,d6         { save a6             }
+
+    move.l  (4),a6        { get ExecBase pointer }
+    move.l  a6,_ExecBase
+    suba.l  a1,a1
+    jsr     _LVOFindTask(a6)
+    move.l  d0,a0
+    { Check the stack value }
+
+    {   are we running from a CLI?             }
+
+    tst.l   172(a0)         { 172 = pr_CLI     }
+    bne     @fromCLI
+
+    { we do not support Workbench yet ..       }
+    move.l  d6,a6           { restore a6       }
+    move.l  #1,d0
+    jsr     HALT_ERROR
+
+@fromCLI:
+    {  Open the following libraries:            }
+    {   Intuition.library                       }
+    {   dos.library                             }
+
+    moveq.l  #0,d0
+    lea      intuitionname,a1
+    jsr      _LVOOpenLibrary(a6)
+    move.l   d0,_IntuitionBase
+    beq      @exitprg
+
+    moveq.l  #0,d0
+    lea      utilityname,a1
+    jsr      _LVOOpenLibrary(a6)
+    move.l   d0,_UtilityBase
+    beq      @exitprg
+
+    moveq.l  #0,d0
+    lea      dosname,a1
+    jsr      _LVOOpenLibrary(a6)
+    move.l   d0,_DOSBase
+    beq      @exitprg
+
+    { Find standard input and output               }
+    { for CLI                                      }
+@OpenFiles:
+    move.l  _DOSBase,a6
+    jsr     _LVOInput(a6)        { get standard in                   }
+    move.l  d0, StdInputHandle   { save standard Input handle        }
+{    move.l  d0,d1               }{ set up for next call              }
+{   jsr     _LVOIsInteractive(a6)}{ is it interactive?             }
+{   move.l  #_Input,a0          }{ get file record again             }
+{   move.b  d0,INTERACTIVE(a0)  }{ set flag                          }
+{   beq     StdInNotInteractive }{ skip this if not interactive    }
+{   move.l  BUFFER(a0),a1       }{ get buffer address                }
+{   add.l   #1,a1               }{ make end one byte further on      }
+{   move.l  a1,MAX(a0)          }{ set buffer size                   }
+{   move.l  a1,CURRENT(a0)      }{ will need a read                  }
+    bra     @OpenStdOutput
+@StdInNotInteractive
+{    jsr _p%FillBuffer     }      { fill the buffer                   }
+@OpenStdOutput
+    jsr     _LVOOutput(a6)      { get ouput file handle             }
+    move.l  d0,StdOutputHandle  { get file record                   }
+    bra     @startupend
+{    move.l  d0,d1             }  { set up for call                   }
+{    jsr _LVOIsInteractive(a6) }  { is it interactive?                }
+{    move.l  #_Output,a0       }  { get file record                   }
+{    move.b  d0,INTERACTIVE(a0)}  { set flag                          }
+@exitprg:
+     move.l d6,a6                 { restore a6                        }
+     move.l #219,d0
+     jsr    HALT_ERROR
+@startupend:
+     move.l d6,a6                 { restore a6                        }
+end;
+
+
+procedure OpenStdIO(var f:text;mode:word;hdl:longint);
+begin
+  Assign(f,'');
+  TextRec(f).Handle:=hdl;
+  TextRec(f).Mode:=mode;
+  TextRec(f).InOutFunc:=@FileInOutFunc;
+  TextRec(f).FlushFunc:=@FileInOutFunc;
+  TextRec(f).Closefunc:=@fileclosefunc;
+end;
+
+
+begin
+{ Startup }
+  Startup;
+  { Only AmigaOS v2.04 or greater is supported }
+  If KickVersion < 36 then
+   Begin
+     WriteLn('v36 or greater of Kickstart required.');
+     Halt(1);
+   end;
+{ Initialize ExitProc }
+  ExitProc:=Nil;
+{ to test stack depth }
+  loweststack:=maxlongint;
+{ Setup heap }
+  InitHeap;
+{ Setup stdin, stdout and stderr }
+  OpenStdIO(Input,fmInput,StdInputHandle);
+  OpenStdIO(Output,fmOutput,StdOutputHandle);
+  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
+{ Reset IO Error }
+  InOutRes:=0;
+end.
+
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:47  root
+  Initial revision
+
+  Revision 1.14  1998/03/21 04:20:09  carl
+    * correct ExecBase pointer (from Nils Sjoholm)
+    * correct OpenLibrary vector (from Nils Sjoholm)
+
+  Revision 1.13  1998/03/14 21:34:32  carl
+    * forgot to save a6 in Startup routine
+
+  Revision 1.12  1998/02/24 21:19:42  carl
+  *** empty log message ***
+
+  Revision 1.11  1998/02/23 02:22:49  carl
+    * bugfix if linking problems
+
+  Revision 1.9  1998/02/06 16:34:32  carl
+    + do_open is now standard with other platforms
+
+  Revision 1.8  1998/02/02 15:01:45  carl
+    * fixed bug with opening library versions (from Nils Sjoholm)
+
+  Revision 1.7  1998/01/31 19:35:19  carl
+    + added opening of utility.library
+
+  Revision 1.6  1998/01/29 23:20:54  peter
+    - Removed Backslash convert
+
+  Revision 1.5  1998/01/27 10:55:04  peter
+    * Amiga uses / not \, so change AllowSlash -> AllowBackSlash
+
+  Revision 1.4  1998/01/25 21:53:20  peter
+    + Universal Handles support for StdIn/StdOut/StdErr
+    * Updated layout of sysamiga.pas
+
+  Revision 1.3  1998/01/24 21:09:53  carl
+    + added missing input/output function pointers
+
+  Revision 1.2  1998/01/24 14:08:25  carl
+    * RunError 217 --> RunError 219 (cannot open lib)
+    + Standard Handle names implemented
+
+  Revision 1.1  1998/01/24 05:12:15  carl
+    + initial revision, some stuff still missing though.
+      (and as you might imagine ... untested :))
+}

rtl/atari/os.inc

@@ -0,0 +1,39 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+{$define atari}
+{$undef go32v2}
+{$undef os2}
+{$undef linux}
+{$undef win32}
+{$undef amiga}
+{$undef macos}
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:47  root
+  Initial revision
+
+  Revision 1.2  1998/01/26 12:02:52  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/atari/os.inc
+  description:
+  ----------------------------
+  revision 1.1
+  date: 1998/01/05 00:38:27;  author: carl;  state: Exp;
+  + Initial revision
+  =============================================================================
+}

rtl/atari/prt0.as

@@ -0,0 +1,209 @@
+|*************************************************************************
+|*                                                                       *
+|*       DSTART.S        Startup module for Pascal programs using dLibs  *
+|*                                                                       *
+|*************************************************************************
+
+|*
+|* entry points
+|*
+.globl  __base                  | basepage pointer
+.globl  __start                 | startup entry point
+.globl  _etext                  | end of text segment
+.globl  _edata                  | end of data segment
+.globl  _end                    | end of BSS segment (end of program)
+.globl  __BREAK                 | location of stack/heap break
+.globl  __exit                  | terminate immediately with exit code
+.globl  __ARGC                  | number of arguments
+.globl  __ARGS                  | argument list pointer
+.globl  __envp                  | environment string pointer
+.globl  _errno                  | system error number
+
+|
+| external references
+|
+|.globl  __stklen               | Stack size value from C (unsigned long)
+
+|
+| useful constants
+|
+MINSTK          =     8192    | Minimum 1K stack size
+MARGIN          =     512     | Minimum memory to return to OS
+
+|
+| GEMDOS functions
+|
+Cconws          =     0x09     | Console write string
+Pterm           =     0x4C     | Process terminate (with exit code)
+Mshrink         =     0x4A     | Shrink program space
+
+|
+| basepage offsets
+|
+p_hitpa         =     0x04     | top of TPA
+p_tbase         =     0x08     | base of text
+p_tlen          =     0x0C     | length of text
+p_dbase         =     0x10     | base of data
+p_dlen          =     0x14     | length of data
+p_bbase         =     0x18     | base of BSS
+p_blen          =     0x1C     | length of BSS
+p_env           =     0x2C     | environment string
+p_cmdlin        =     0x80     | command line image
+
+|
+| STARTUP ROUTINE (must be first object in link)
+|
+.text
+   .globl start
+   .globl _start
+
+__start:
+start:
+_start:
+|
+| save initial stack and basepage pointers
+|
+	movel  sp,a5                   | a5 = initial stack pointer
+	movel  sp@(4),a4                | a4 = basepage address
+	movel  a4,__base
+	movel  a4@(p_tbase),d3
+	addl   a4@(p_tlen),d3
+	movel  d3,_etext               | end of text segment
+	movel  a4@(p_dbase),d3
+	addl   a4@(p_dlen),d3
+	movel  d3,_edata               | end of data segment
+	movel  a4@(p_bbase),d3
+	addl   a4@(p_blen),d3
+	movel  d3,_end                 | end of BSS (end of program)
+	movel  d3,__BREAK;             | set initial _break value
+	movel  a4@(p_env),__envp        | save environment pointer
+|
+| call C function to get command line arguments
+|
+	lea   a4@(p_cmdlin),a0         | get pointer to command line image
+	moveb  a0@+,d0
+	extw   d0                     | extract length
+|	movew  d0,sp@-                | cmdlen
+|	movel  a0,sp@-                | cmdline
+|	jsr     __initar              | call _initargs(cmdline, cmdlen)
+|	addql  #6,sp
+   movew  d0,__ARGC              | save length
+   movel  a0,__ARGS              | save pointer to string
+|
+| calculate free space available to program
+|
+	movel  __BREAK,d3
+	movel  d3,a3                   | a3 = base of free space
+	negl   d3
+	addl   a4@(p_hitpa),d3
+	subl   #MARGIN,d3              | d3 = free space
+|
+| calculate new stack size (store in d2)
+|
+| ASSUME 8K STACK FOR THE MOMENT.
+|	movel   __stklen,a2            | a2 = &_STKSIZ
+|	movel   a2,d2                   | if __STKSIZ is undefined
+	bra     minimum                 |   use MINSTK
+	movel   a2@,d2                 | if __STKSIZ is positive
+	bpl     setstk                  |   use __STKSIZ
+	addl    d3,d2                   | if __STKSIZ is negative
+	cmpl    #MINSTK,d2              |   try (free space + __STKSIZ)
+	bge     setstk                  | if < MINSTK
+minimum:
+	movel  #MINSTK,d2              |   use MINSTK
+|
+| check to see if there is enough room for requested stack
+|
+setstk:
+	cmpl   d3,d2
+	blt     shrink                  | if (available < requested)
+	movel  #stkerr,sp@-
+	movew  #Cconws,sp@-
+	trap    #1                      |   report a stack error
+	addql  #6,sp
+	movew  #-39,sp@-
+	movew  #Pterm,sp@-
+	trap    #1                      |   and return error -39 (ENSMEM)
+|
+| set up new stack pointer and Mshrink
+|
+shrink:
+	addl   a3,d2                   | new stack = free base + stack size
+	movel  d2,sp
+	subl   a4,d2                   | keep space = new stack - __base
+	movel  d2,sp@-
+	movel  a4,sp@-
+	clrw   sp@-
+	movew  #Mshrink,sp@-
+	trap    #1                      | Mshrink(0, _base, keep);
+	addl   #12,sp
+|
+| call C entry point function _main()
+|
+	jsr     PASCALMAIN               | if _main returns
+	movew   d0,sp@(4)                |   insert return value and fall thru
+
+
+
+|
+| check for stack overflow (done after all OS traps)
+|
+chkstk:
+	cmpl    __BREAK,sp
+	bgt     nosweat                 | if (_break > sp)
+	movel   #stkovf,sp@-
+	movew   #Cconws,sp@-
+	trap    #1                      |   report a stack overflow
+	addql   #6,sp
+	movew   #-1,sp@-
+	movew   #Pterm,sp@-
+	trap    #1                      |   and return error -1 (ERROR)
+nosweat:
+	movel   traprtn,sp@-           | else, restore return address
+	rts                             | and do a normal return.
+
+|
+| this call to _main ensures that it the user's main() function will be
+| linked, even if it is in a library.
+|
+	jsr     PASCALMAIN                   | NO PATH TO THIS STATEMENT
+   movew   d0,sp@-
+   movew   #0x4c,sp@-
+   trap    #1
+
+
+|
+| initialized data space
+|
+.data
+.even
+stkerr:                                 | not enough memory for stack
+	.ascii   "Not enough memory"
+   .byte     0x0d,0x0a,0x00
+stkovf:                                 | impending stack overflow
+	.ascii   "Stack overflow"
+   .byte     0x0d,0x0a,0x00
+_errno:                                 | system error number
+	.word   0
+__ARGC:                                 | number of command line args
+	.word   0
+__ARGS:                                 | pointer to command line arg list
+	.long   0
+|
+| uninitialized data space
+|
+.even
+__base:                                 | pointer to basepage
+   .long  0
+_etext:                                 | pointer to end of text segment
+   .long  0
+_edata:                                 | pointer to end of data segment
+   .long  0
+_end:                                   | pointer to end of BSS (end of program)
+   .long  0
+__BREAK:                                | pointer to stack/heap break
+   .long 0
+__envp:                                 | pointer to environment string
+   .long 0
+traprtn:                                | storage for return PC in trap hooks
+   .long 0

rtl/atari/readme

@@ -0,0 +1,4 @@
+For the moment there is no makefile for the atari system unit, therefore 
+to compile you must copy all files from the inc and m68k directories into 
+the same directory as the files here.
+

rtl/atari/sysatari.pas

@@ -0,0 +1,589 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+{$define ATARI}
+unit sysatari;
+
+
+{ Left to do :                                                    }
+{    - Fix DOSError codes to conform to those of DOS (TP)         }
+
+{$I os.inc}
+
+  interface
+
+    { used for single computations }
+    const BIAS4 = $7f-1;
+
+    {$I systemh.inc}
+
+    {$I heaph.inc}
+
+const
+  UnusedHandle    = $ffff; 
+  StdInputHandle  = 0;
+  StdOutputHandle = 1;
+  StdErrorHandle  = $ffff; 
+
+  implementation
+
+    {$I system.inc}
+    {$I lowmath.inc}
+
+    type
+       plongint = ^longint;
+
+{$S-}
+    procedure st1(stack_size : longint);[public,alias: 'STACKCHECK'];
+
+      begin
+         { called when trying to get local stack }
+         { if the compiler directive $S is set   }
+         { it must preserve all registers !!     }
+         asm
+           move.l   sp,d0
+           sub.l    stack_size,d0
+           cmp.l    __BREAK,d0
+           bgt      @st1nosweat
+           move.l   #202,d0
+           jsr      HALT_ERROR
+         @st1nosweat:
+         end;
+      end;
+
+
+    procedure halt(errnum : byte);
+
+      begin
+         do_exit;
+         flush(stderr);
+         asm
+            clr.l   d0
+            move.b  errnum,d0
+            move.w  d0,-(sp)
+            move.w  #$4c,-(sp)
+            trap    #1
+         end;
+      end;
+
+    function paramcount : longint; assembler;
+    asm
+            clr.l   d0
+            move.w  __ARGC,d0
+            sub.w   #1,d0
+    end;
+
+    function paramstr(l : longint) : string;
+
+      function args : pointer; assembler;
+      asm
+         move.l __ARGS,d0
+      end;
+
+      var
+         p : ^pchar;
+
+      begin
+         if (l>=0) and (l<=paramcount) then
+           begin
+              p:=args;
+              paramstr:=strpas(p[l]);
+           end
+         else paramstr:='';
+      end;
+
+    procedure randomize;
+
+      var
+         hl : longint;
+
+      begin
+         asm
+           movem.l d2/d3/a2/a3, -(sp)     { save OS registers }
+           move.w #17,-(sp)
+           trap   #14         { call xbios - random number }
+           add.l  #2,sp
+           movem.l (sp)+,d2/d3/a2/a3
+           move.l d0,hl       { result in d0 }
+         end;
+         randseed:=hl;
+      end;
+
+  { This routine is used to grow the heap.  }
+  { But here we do a trick, we say that the }
+  { heap cannot be regrown!                 }
+  function sbrk( size: longint): longint;
+  { on exit -1 = if fails.               }
+  Begin
+   sbrk:=-1;
+  end;
+
+{$I heap.inc}
+
+
+{****************************************************************************
+                          Low Level File Routines
+ ****************************************************************************}
+
+procedure AllowSlash(p:pchar);
+var
+  i : longint;
+begin
+{ allow slash as backslash }
+  for i:=0 to strlen(p) do
+   if p[i]='/' then p[i]:='\';
+end;
+
+
+procedure do_close(h : longint);
+begin
+  asm
+        movem.l d2/d3/a2/a3,-(sp)
+        move.l  h,-(sp)
+        move.w  #$3e,-(sp)
+        trap    #1
+        add.l   #4,sp      { restore stack ... }
+        movem.l (sp)+,d2/d3/a2/a3
+  end;
+end;
+
+
+procedure do_erase(p : pchar);
+begin
+  AllowSlash(p);
+  asm
+        move.l  d2,d6            { save d2   }
+        movem.l d3/a2/a3,-(sp)   { save regs }
+        pea    8(a6)
+        move.w #$41,-(sp)
+        trap   #1
+        add.l  #6,sp
+        move.l d6,d2       { restore d2 }
+        movem.l (sp)+,d3/a2/a3
+        tst.w  d0
+        beq    @doserend
+        move.w d0,InOutRes
+        @doserend:
+  end;
+end;
+
+
+procedure do_rename(p1,p2 : pchar);
+begin
+  AllowSlash(p1);
+  AllowSlash(p2);
+  asm
+            move.l  d2,d6      { save d2 }
+            movem.l d3/a2/a3,-(sp)
+            pea     p1
+            pea     p2
+            clr.w   -(sp)
+            move.w  #$56,-(sp)
+            trap    #1
+            lea     12(sp),sp
+            move.l  d6,d2       { restore d2 }
+            movem.l (sp)+,d3/a2/a3
+            tst.w   d0
+            beq     @dosreend
+            move.w  d0,InOutRes    { error ... }
+         @dosreend:
+  end;
+end;
+
+
+function do_write(h,addr,len : longint) : longint;
+begin
+  asm
+            move.l  d2,d6      { save d2 }
+            movem.l d3/a2/a3,-(sp)
+            pea     addr
+            pea     len
+            move.w  h,-(sp)
+            move.w  #$40,-(sp)
+            trap    #1
+            lea     12(sp),sp
+            move.l d6,d2       { restore d2 }
+            movem.l (sp)+,d3/a2/a3
+            tst.l   d0
+            bpl     @doswrend
+            move.w  d0,InOutRes    { error ... }
+          @doswrend:
+            move.l  d0,@RESULT
+  end;
+end;
+
+
+function do_read(h,addr,len : longint) : longint;
+begin
+  asm
+            move.l  d2,d6      { save d2 }
+            movem.l d3/a2/a3,-(sp)
+            pea    addr
+            pea    len
+            move.w h,-(sp)
+            move.w #$40,-(sp)
+            trap   #1
+            lea    12(sp),sp
+            move.l d6,d2       { restore d2 }
+            movem.l (sp)+,d3/a2/a3
+            tst.l   d0
+            bpl     @dosrdend
+            move.w  d0,InOutRes    { error ... }
+          @dosrdend:
+            move.l  d0,@Result
+  end;
+end;
+
+
+function do_filepos(handle : longint) : longint;
+begin
+  asm
+            move.l  d2,d6      { save d2 }
+            movem.l d3/a2/a3,-(sp)
+            move.w #1,-(sp)     { seek from current position }
+            move.w handle,-(sp)
+            move.l #0,-(sp)     { with a seek offset of zero }
+            move.w #$42,-(sp)
+            trap   #1
+            lea    10(sp),sp
+            move.l d6,d2       { restore d2 }
+            movem.l (sp)+,d3/a2/a3
+            move.l d0,@Result
+  end;
+end;
+
+
+procedure do_seek(handle,pos : longint);
+begin
+  asm
+            move.l  d2,d6      { save d2 }
+            movem.l d3/a2/a3,-(sp)
+            move.w #0,-(sp)     { seek from start of file    }
+            move.w handle,-(sp)
+            pea    pos
+            move.w #$42,-(sp)
+            trap   #1
+            lea    10(sp),sp
+            move.l d6,d2       { restore d2 }
+            movem.l (sp)+,d3/a2/a3
+  end;
+end;
+
+
+function do_seekend(handle:longint):longint;
+var
+ t: longint;
+begin
+  asm
+            move.l  d2,d6      { save d2 }
+            movem.l d3/a2/a3,-(sp)
+            move.w #2,-(sp)     { seek from end of file        }
+            move.w handle,-(sp)
+            move.l #0,-(sp)     { with an offset of 0 from end }
+            move.w #$42,-(sp)
+            trap   #1
+            lea    10(sp),sp
+            move.l d6,d2       { restore d2 }
+            movem.l (sp)+,d3/a2/a3
+            move.l d0,t
+  end;
+   do_seekend:=t;
+end;
+
+
+function do_filesize(handle : longint) : longint;
+var
+   aktfilepos : longint;
+begin
+   aktfilepos:=do_filepos(handle);
+   do_filesize:=do_seekend(handle);
+   do_seek(handle,aktfilepos);
+end;
+
+
+procedure do_truncate (handle,pos:longint);
+begin
+  do_seek(handle,pos);
+  {!!!!!!!!!!!!}
+end;
+
+
+procedure do_open(var f;p:pchar;flags:longint);
+{
+  filerec and textrec have both handle and mode as the first items so
+  they could use the same routine for opening/creating.
+  when (flags and $10)   the file will be append
+  when (flags and $100)  the file will be truncate/rewritten
+  when (flags and $1000) there is no check for close (needed for textfiles)
+}
+var
+  i : longint;
+  oflags: longint;
+begin
+  AllowSlash(p);
+ { close first if opened }
+  if ((flags and $1000)=0) then
+   begin
+     case filerec(f).mode of
+      fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
+      fmclosed : ;
+     else
+      begin
+        inoutres:=102; {not assigned}
+        exit;
+      end;
+     end;
+   end;
+{ reset file handle }
+  filerec(f).handle:=UnusedHandle;
+  oflags:=$04;
+{ convert filemode to filerec modes }
+  case (flags and 3) of
+   0 : begin
+         filerec(f).mode:=fminput;
+         oflags:=$01;
+       end;
+   1 : filerec(f).mode:=fmoutput;
+   2 : filerec(f).mode:=fminout;
+  end;
+  if (flags and $100)<>0 then
+   begin
+     filerec(f).mode:=fmoutput;
+     oflags:=$02;
+   end
+  else
+   if (flags and $10)<>0 then
+    begin
+      filerec(f).mode:=fmoutput;
+      oflags:=$04;
+    end;
+{ empty name is special }
+  if p[0]=#0 then
+   begin
+     case filerec(f).mode of
+       fminput : filerec(f).handle:=StdInputHandle;
+      fmappend,
+      fmoutput : begin
+                   filerec(f).handle:=StdOutputHandle;
+                   filerec(f).mode:=fmoutput; {fool fmappend}
+                 end;
+     end;
+     exit;
+   end;
+   asm
+      movem.l d2/d3/a2/a3,-(sp)    { save used registers }
+
+      cmp.l   #4,oflags    { check if append mode ... }
+      bne     @opencont2
+      move.w  #2,d0        { append mode... r/w open   }
+      bra     @opencont1
+    @opencont2:
+      move.l  oflags,d0    { use flag as source  ...    }
+    @opencont1:
+      move.w  d0,-(sp)
+      pea     f
+      move.w  #$3d,-(sp)
+      trap    #1
+      add.l   #8,sp       { restore stack of os call }
+
+      movem.l (sp)+,d2/d3/a2/a3
+
+      tst.l   d0
+      bpl     @opennoerr
+      move.w  d0,InOutRes
+    @opennoerr:
+      move.l  d0,i        { get handle ... }
+    end;
+    filerec(f).handle:=i;
+  if (flags and $10)<>0 then
+   do_seekend(filerec(f).handle);
+end;
+
+{*****************************************************************************
+                           UnTyped File Handling
+*****************************************************************************}
+
+{$i file.inc}
+
+{*****************************************************************************
+                           Typed File Handling
+*****************************************************************************}
+
+{$i typefile.inc}
+
+{*****************************************************************************
+                           Text File Handling
+*****************************************************************************}
+
+{$i text.inc}
+
+{*****************************************************************************
+                           Directory Handling
+*****************************************************************************}
+
+procedure DosDir(func:byte;const s:string);
+var
+  buffer : array[0..255] of char;
+begin
+  move(s[1],buffer,length(s));
+  buffer[length(s)]:=#0;
+  AllowSlash(pchar(@buffer));
+  asm
+        move.l  d2,d6      { save d2 }
+        movem.l d3/a2/a3,-(sp)
+        pea     buffer
+        move.b  func,-(sp)
+        trap    #1
+        add.l   #6,sp
+        move.l  d6,d2       { restore d2 }
+        movem.l (sp)+,d3/a2/a3
+        tst.w   d0
+        beq     @dosdirend
+        move.w  d0,InOutRes
+     @dosdirend:
+  end;
+end;
+
+
+procedure mkdir(const s : string);
+begin
+  DosDir($39,s);
+end;
+
+
+procedure rmdir(const s : string);
+begin
+  DosDir($3a,s);
+end;
+
+
+procedure chdir(const s : string);
+begin
+  DosDir($3b,s);
+end;
+
+
+procedure getdir(drivenr : byte;var dir : string);
+var
+  temp : array[0..255] of char;
+  sof  : pchar;
+  i    : longint;
+begin
+  sof:=pchar(@dir[4]);
+  asm
+            move.l  d2,d6      { save d2 }
+            movem.l d3/a2/a3,-(sp)
+
+            { Get dir from drivenr : 0=default, 1=A etc... }
+            move.w drivenr,-(sp)
+
+            { put (previously saved) offset in si }
+            pea    dir
+
+            { call attos function 47H : Get dir }
+            move.w #$47,-(sp)
+
+            { make the call }
+            trap   #1
+            add.l  #8,sp
+
+            move.l d6,d2         { restore d2 }
+            movem.l (sp)+,d3/a2/a3
+  end;
+{ Now Dir should be filled with directory in ASCIIZ, }
+{ starting from dir[4]                               }
+  dir[0]:=#3;
+  dir[2]:=':';
+  dir[3]:='\';
+  i:=4;
+{ conversation to Pascal string }
+  while (dir[i]<>#0) do
+   begin
+   { convert path name to DOS }
+     if dir[i]='/' then
+      dir[i]:='\';
+     dir[0]:=chr(i);
+     inc(i);
+   end;
+{ upcase the string (FPKPascal function) }
+  dir:=upcase(dir);
+  if drivenr<>0 then   { Drive was supplied. We know it }
+   dir[1]:=chr(65+drivenr-1)
+  else
+   begin
+      asm
+        move.l  d2,d6      { save d2 }
+        movem.l d3/a2/a3,-(sp)
+        move.w #$19,-(sp)
+        trap   #1
+        add.l  #2,sp
+        move.l d6,d2        { restore d2 }
+        movem.l (sp)+,d3/a2/a3
+     end;
+     dir[1]:=chr(i);
+   end;
+end;
+
+      
+{*****************************************************************************
+                         SystemUnit Initialization
+*****************************************************************************}
+      
+procedure OpenStdIO(var f:text;mode:word;hdl:longint);
+begin
+  Assign(f,'');
+  TextRec(f).Handle:=hdl;
+  TextRec(f).Mode:=mode;
+  TextRec(f).InOutFunc:=@FileInOutFunc;
+  TextRec(f).FlushFunc:=@FileInOutFunc;
+  TextRec(f).Closefunc:=@fileclosefunc;
+end;
+
+      
+begin
+{ Initialize ExitProc }
+  ExitProc:=Nil;
+{ to test stack depth }
+  loweststack:=maxlongint;
+{ Setup heap }
+  InitHeap;
+{ Setup stdin, stdout and stderr }
+  OpenStdIO(Input,fmInput,StdInputHandle);
+  OpenStdIO(Output,fmOutput,StdOutputHandle);
+  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
+{ Reset IO Error }
+  InOutRes:=0;
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:47  root
+  Initial revision
+
+  Revision 1.8  1998/02/23 02:27:39  carl
+    * make it link correctly
+
+  Revision 1.7  1998/02/06 16:33:02  carl
+    * oops... commited wrong file
+    + do_open is now standard with other platforms
+
+  Revision 1.5  1998/01/31 19:32:51  carl
+    - removed incorrect $define
+
+  Revision 1.4  1998/01/27 10:55:45  peter
+    * Word Handles from -1 -> $ffff
+
+  Revision 1.3  1998/01/25 22:44:14  peter
+    * Using uniform layout
+
+}

rtl/dos/crt.pp

@@ -0,0 +1,891 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by Florian Klaempfl,
+    member of the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+{
+  history:
+  29th may 1994: version 1.0
+             unit is completed
+  14th june 1994: version 1.01
+             the address from which startaddr was read wasn't right; fixed
+  18th august 1994: version 1.1
+             the upper left corner of winmin is now 0,0
+  19th september 1994: version 1.11
+             keypressed handles extended keycodes false; fixed
+  27th february 1995: version 1.12
+             * crtinoutfunc didn't the line wrap in the right way;
+               fixed
+  20th january 1996: version 1.13
+             - unused variables removed
+  21th august 1996: version 1.14
+             * adapted to newer FPKPascal versions
+             * make the comments english
+   6th november 1996: version 1.49
+             * some stuff for DPMI adapted
+  15th november 1996: version 1.5
+             * bug in screenrows fixed
+  13th november 1997: removed textrec definition, is now included from 
+               textrec.inc
+}
+
+unit crt;
+
+{$I os.inc}
+
+  interface
+  
+    uses
+       go32;
+
+    const
+       { screen modes }
+       bw40 = 0;
+       co40 = 1;
+       bw80 = 2;
+       co80 = 3;
+       mono = 7;
+       font8x8 = 256;
+
+       { screen color, fore- and background }
+       black = 0;
+       blue = 1;
+       green = 2;
+       cyan = 3;
+       red = 4;
+       magenta = 5;
+       brown = 6;
+       lightgray = 7;
+
+       { only foreground }
+       darkgray = 8;
+       lightblue = 9;
+       lightgreen = 10;
+       lightcyan = 11;
+       lightred = 12;
+       lightmagenta = 13;
+       yellow = 14;
+       white = 15;
+
+       { blink flag }
+       blink = $80;
+
+    const
+    {$ifndef GO32V2}
+       directvideo:boolean=true;
+    {$else GO32V2}
+       { direct video generates a GPF in DPMI of setcursor }
+       directvideo:boolean=false;
+    {$endif GO32V2}
+
+    var
+       { for compatibility }
+       checkbreak,checkeof,checksnow : boolean;
+
+       lastmode : word; { screen mode}
+       textattr : byte; { current text attribute }
+       windmin  : word; { upper right corner of the CRT window }
+       windmax  : word; { lower left corner of the CRT window }
+
+    function keypressed : boolean;
+    function readkey : char;
+    procedure gotoxy(x,y : byte);
+    procedure window(left,top,right,bottom : byte);
+    procedure clrscr;
+    procedure textcolor(color : byte);
+    procedure textbackground(color : byte);
+    procedure assigncrt(var f : text);
+    function wherex : byte;
+    function wherey : byte;
+    procedure delline;
+    procedure delline(line : byte);
+    procedure clreol;
+    procedure insline;
+    procedure cursoron;
+    procedure cursoroff;
+    procedure cursorbig;
+    procedure lowvideo;
+    procedure highvideo;
+    procedure nosound;
+    procedure sound(hz : word);
+    procedure delay(ms : longint);
+    procedure textmode(mode : integer);
+    procedure normvideo;
+    
+  implementation
+  
+    var
+       maxcols,maxrows : longint;
+
+    { definition of textrec is in textrec.inc}
+
+    {$i textrec.inc}
+
+    { low level routines }
+
+    function getscreenmode : byte;
+
+      begin
+         dosmemget($40,$49,getscreenmode,1);
+      end;
+
+    procedure setscreenmode(mode : byte);
+
+     var regs : trealregs;
+
+      begin
+{$ifdef GO32V2}
+         regs.realeax:=mode;
+         realintr($10,regs);
+{$else GO32V2}
+         asm
+            movb 8(%ebp),%al
+            xorb %ah,%ah
+            pushl %ebp
+            int $0x10
+            popl %ebp
+         end;
+{$endif GO32V2}
+      end;
+
+    function screenrows : byte;
+
+      begin
+         dosmemget($40,$84,screenrows,1);
+         { don't forget this: }
+         inc(screenrows);
+      end;
+
+    function screencols : byte;
+
+      begin
+         dosmemget($40,$4a,screencols,1);
+      end;
+
+    function get_addr(row,col : byte) : word;
+
+      begin
+         get_addr:=((row-1)*maxcols+(col-1))*2;
+      end;
+
+    procedure screensetcursor(row,col : longint);
+
+      var
+         cols : byte;
+         pos : word;
+
+{$ifdef GO32V2}
+         regs : trealregs;
+{$endif GO32V2}
+      begin
+         if directvideo then
+           begin
+              { set new position for the BIOS }
+              dosmemput($40,$51,row,1);
+              dosmemput($40,$50,col,1);
+
+              { calculates screen position }
+              dosmemget($40,$4a,cols,1);
+              { FPKPascal calculates with 32 bit }
+              pos:=row*cols+col;
+
+              { direct access to the graphics card registers }
+              outportb($3d4,$0e);
+              outportb($3d5,hi(pos));
+              outportb($3d4,$0f);
+              outportb($3d5,lo(pos));
+           end
+         else
+{$ifndef GO32V2}
+            asm
+               movb     $0x02,%ah
+               movb     $0,%bh
+               movb     row,%dh
+               movb     col,%dl
+               pushl    %ebp
+               int      $0x10
+               popl     %ebp
+            end;
+{$else GO32V2}
+            regs.realeax:=$0200;
+            regs.realebx:=0;
+            regs.realedx:=row*$100+col;
+            realintr($10,regs);
+{$endif GO32V2}
+       end;
+
+    procedure screengetcursor(var row,col : longint);
+
+      begin
+         col:=0;
+         row:=0;
+         dosmemget($40,$50,col,1);
+         dosmemget($40,$51,row,1);
+      end;
+
+    { exported routines }
+
+    procedure cursoron;
+
+{$ifdef GO32V2}
+    var     regs : trealregs;
+{$endif GO32V2}
+      begin
+{$ifndef GO32V2}
+         asm
+            movb   $1,%ah
+            movb   $10,%cl
+            movb   $9,%ch
+            pushl %ebp
+            int   $0x10
+            popl %ebp
+         end;
+{$else GO32V2}
+            regs.realeax:=$0100;
+            regs.realecx:=$90A;
+            realintr($10,regs);
+{$endif GO32V2}
+      end;
+
+    procedure cursoroff;
+
+{$ifdef GO32V2}
+    var     regs : trealregs;
+{$endif GO32V2}
+      begin
+{$ifndef GO32V2}
+         asm
+            movb   $1,%ah
+            movb   $-1,%cl
+            movb   $-1,%ch
+            pushl %ebp
+            int   $0x10
+            popl %ebp
+         end;
+{$else GO32V2}
+            regs.realeax:=$0100;
+            regs.realecx:=$ffff;
+            realintr($10,regs);
+{$endif GO32V2}
+      end;
+
+    procedure cursorbig;
+
+{$ifdef GO32V2}
+    var     regs : trealregs;
+{$endif GO32V2}
+      begin
+{$ifdef GO32V2}
+            regs.realeax:=$0100;
+            regs.realecx:=$10A;
+            realintr($10,regs);
+{$else GO32V2}
+         asm
+            movb   $1,%ah
+            movb   $10,%cl
+            movb   $1,%ch
+            pushl %ebp
+            int   $0x10
+            popl %ebp
+         end;
+{$endif GO32V2}
+      end;
+
+    var
+       is_last : boolean;
+       last : char;
+
+    function readkey : char;
+
+      var
+         char2 : char;
+         char1 : char;
+{$ifdef GO32V2}
+    var     regs : trealregs;
+{$endif GO32V2}
+
+      begin
+         if is_last then
+           begin
+              is_last:=false;
+              readkey:=last;
+           end
+         else
+           begin
+{$ifdef GO32V2}
+            regs.realeax:=$0000;
+            realintr($16,regs);
+            byte(char1):=regs.realeax and $ff;
+            byte(char2):=(regs.realeax and $ff00) div $100;
+{$else GO32V2}
+              asm
+                 movb $0,%ah
+                 pushl %ebp
+                 int $0x16
+                 popl %ebp
+                 movw %ax,-2(%ebp)
+              end;
+{$endif GO32V2}
+              if char1=#0 then
+                begin
+                   is_last:=true;
+                   last:=char2;
+                end;
+              readkey:=char1;
+           end;
+      end;
+
+    function keypressed : boolean;
+
+{$ifdef GO32V2}
+   var regs : trealregs;
+{$endif GO32V2}
+      begin
+         if is_last then
+           begin
+              keypressed:=true;
+              exit;
+           end
+         else
+{$ifdef GO32V2}
+         begin
+            regs.realeax:=$0100;
+            realintr($16,regs);
+            if (regs.realflags and zeroflag) = 0 then
+              keypressed:=true
+              else keypressed:=false;
+         end;
+{$else GO32V2}
+           asm
+              movb $1,%ah
+              pushl %ebp
+              int $0x16
+              popl %ebp
+              setnz %al
+              movb %al,__RESULT
+           end;
+{$endif GO32V2}
+      end;
+
+   procedure gotoxy(x,y : byte);
+
+     begin
+        if (x<1) then
+          x:=1;
+        if (y<1) then
+          y:=1;
+        if y+hi(windmin)-2>=hi(windmax) then
+          y:=hi(windmax)-hi(windmin)+1;
+        if x+lo(windmin)-2>=lo(windmax) then
+          x:=lo(windmax)-lo(windmin)+1;
+        screensetcursor(y+hi(windmin)-1,x+lo(windmin)-1);
+     end;
+
+   function wherex : byte;
+
+     var
+        row,col : longint;
+
+     begin
+        screengetcursor(row,col);
+        wherex:=col-lo(windmin)+1;
+     end;
+
+   function wherey : byte;
+
+     var
+        row,col : longint;
+
+     begin
+        screengetcursor(row,col);
+        wherey:=row-hi(windmin)+1;
+     end;
+
+   procedure window(left,top,right,bottom : byte);
+
+     begin
+        if (left<1) or
+           (right>screencols) or
+           (bottom>screenrows) or
+           (left>right) or
+           (top>bottom) then
+           exit;
+        windmin:=(left-1) or ((top-1) shl 8);
+        windmax:=(right-1) or ((bottom-1) shl 8);
+        gotoxy(1,1);
+     end;
+
+   procedure clrscr;
+
+     var
+        fil : word;
+        row : longint;
+
+     begin
+        fil:=32 or (textattr shl 8);
+        for row:=hi(windmin) to hi(windmax) do
+          dosmemfillword($b800,get_addr(row+1,lo(windmin)+1),lo(windmax)-lo(windmin)+1,fil);
+        gotoxy(1,1);
+     end;
+
+   procedure textcolor(color : Byte);
+
+     begin
+        textattr:=(textattr and $70) or color;
+     end;
+
+   procedure lowvideo;
+
+     begin
+        textattr:=textattr and $f7;
+     end;
+
+   procedure highvideo;
+
+     begin
+        textattr:=textattr or $08;
+     end;
+
+   procedure textbackground(color : Byte);
+
+     begin
+        textattr:=(textattr and $8f) or ((color and $7) shl 4);
+     end;
+
+   var
+      startattrib : byte;
+
+   procedure normvideo;
+
+     begin
+        textattr:=startattrib;
+     end;
+
+   procedure delline(line : byte);
+
+     var
+        row,left,right,bot : longint;
+        fil : word;
+
+     begin
+        row:=line+hi(windmin);
+        left:=lo(windmin)+1;
+        right:=lo(windmax)+1;
+        bot:=hi(windmax)+1;
+        fil:=32 or (textattr shl 8);
+        while (row<bot) do
+          begin
+             dosmemmove($b800,get_addr(row+1,left),$b800,get_addr(row,left),(right-left+1)*2);
+             inc(row);
+          end;
+        dosmemfillword($b800,get_addr(bot,left),right-left+1,fil);
+     end;
+
+   procedure delline;
+
+     begin
+        delline(wherey);
+     end;
+
+   procedure insline;
+
+     var
+        row,col,left,right,bot : longint;
+        fil : word;
+
+     begin
+        screengetcursor(row,col);
+        inc(row);
+        left:=lo(windmin)+1;
+        right:=lo(windmax)+1;
+        bot:=hi(windmax);
+        fil:=32 or (textattr shl 8);
+        while (bot>row) do
+          begin
+             dosmemmove($b800,get_addr(bot-1,left),$b800,get_addr(bot,left),(right-left+1)*2);
+             dec(bot);
+          end;
+        dosmemfillword($b800,get_addr(row,left),right-left+1,fil);
+     end;
+
+   procedure clreol;
+
+     var
+        row,col : longint;
+        fil : word;
+
+     begin
+        screengetcursor(row,col);
+        inc(row);
+        inc(col);
+        fil:=32 or (textattr shl 8);
+        dosmemfillword($b800,get_addr(row,col),lo(windmax)-col+2,fil);
+     end;
+
+
+   Function CrtWrite(var f : textrec):integer;
+
+      var
+         i,col,row : longint;
+         c : char;
+         va,sa : word;
+
+      begin
+         screengetcursor(row,col);
+         inc(row);
+         inc(col);
+         va:=get_addr(row,col);
+         for i:=0 to f.bufpos-1 do
+           begin
+              c:=f.buffer[i];
+              case ord(c) of
+                 10 : begin
+                         inc(row);
+                         va:=va+maxcols*2;
+                      end;
+                 13 : begin
+                         col:=lo(windmin)+1;
+                         va:=get_addr(row,col);
+                     end;
+                 8 : if col>lo(windmin)+1 then
+                       begin
+                          dec(col);
+                          va:=va-2;
+                       end;
+                 7 : begin
+                         { beep }
+                      end;
+              else
+                 begin
+                    sa:=textattr shl 8 or ord(c);
+                    dosmemput($b800,va,sa,sizeof(sa));
+                    inc(col);
+                    va:=va+2;
+                 end;
+              end;
+              if col>lo(windmax)+1 then
+                begin
+                   col:=lo(windmin)+1;
+                   inc(row);
+                   { it's easier to calculate the new address }
+                   { it don't spend much time                 }
+                   va:=get_addr(row,col);
+                end;
+              while row>hi(windmax)+1 do
+                begin
+                   delline(1);
+                   dec(row);
+                   va:=va-maxcols*2;
+                end;
+           end;
+         f.bufpos:=0;
+         screensetcursor(row-1,col-1);
+         CrtWrite:=0;
+      end;
+
+   Function CrtClose(Var F: TextRec): Integer;
+     Begin
+       F.Mode:=fmClosed;
+       CrtClose:=0;
+     End;
+
+   Function CrtOpen(Var F: TextRec): Integer;
+     Begin
+       If F.Mode = fmOutput Then
+        CrtOpen:=0
+       Else
+        CrtOpen:=5;
+     End;
+
+   Function CrtRead(Var F: TextRec): Integer;
+     Begin
+     {$IFDEF GO32V2}
+       f.bufend:=do_read(f.handle,longint(f.bufptr),f.bufsize);
+     {$ENDIF}
+       f.bufpos:=0;
+       CrtRead:=0;
+     End;
+
+   Function CrtInOut(Var F: TextRec): Integer;
+     Begin
+       Case F.Mode of
+        fmInput: CrtInOut:=CrtRead(F);
+        fmOutput: CrtInOut:=CrtWrite(F);
+       End;
+     End;
+
+   procedure assigncrt(var f : text);
+     begin
+        TextRec(F).Mode:=fmClosed;
+        TextRec(F).BufSize:=SizeOf(TextBuf);
+        TextRec(F).BufPtr:=@TextRec(F).Buffer;
+        TextRec(F).BufPos:=0;
+        TextRec(F).OpenFunc:=@CrtOpen;
+        TextRec(F).InOutFunc:=@CrtInOut;
+        TextRec(F).FlushFunc:=@CrtInOut;
+        TextRec(F).CloseFunc:=@CrtClose;
+        TextRec(F).Name[0]:='.';
+        TextRec(F).Name[1]:=#0;
+     end;
+
+   procedure sound(hz : word);
+
+     begin
+        if hz=0 then
+          begin
+             nosound;
+             exit;
+          end;
+        asm
+           movzwl hz,%ecx
+           movl $1193046,%eax
+	   cdq
+           divl %ecx
+           movl %eax,%ecx
+           movb $0xb6,%al
+           outb %al,$0x43
+           movb %cl,%al
+           outb %al,$0x42
+           movb %ch,%al
+           outb %al,$0x42
+           inb $0x61,%al
+           orb $0x3,%al
+           outb %al,$0x61
+        end ['EAX','ECX','EDX'];
+     end;
+
+   procedure nosound;
+
+     begin
+        asm
+           inb $0x61,%al
+           andb $0xfc,%al
+           outb %al,$0x61
+        end ['EAX'];
+     end;
+
+   var
+      calibration : longint;
+
+   procedure delay(ms : longint);
+
+      var
+         i,j : longint;
+
+     begin
+        for i:=1 to ms do
+          for j:=1 to calibration do
+             begin
+             end;
+     end;
+
+  function get_ticks:longint;
+
+    begin
+       dosmemget($40,$6c,get_ticks,4);
+    end;
+
+  procedure initdelay;
+  
+       { From the mailling list, 
+         by Jonathan Anderson ([email protected]) }
+
+    const
+       threshold=3;
+       { Raise this to increase speed but decrease accuracy        }
+       { currently the calibration will be no more than 7 off      }
+       { and shave a few ticks off the most accurate setting of 0  }
+       { The best values to pick are powers of 2-1 (0,1,3,7,15...) }
+       { but any non-negative value will work.                     }
+
+    var
+       too_small : boolean;
+       first,
+       incval    : longint;
+
+    begin
+       calibration:=0;
+       { wait for new tick }
+       first:=get_ticks;
+       while get_ticks=first do
+         begin
+         end;
+       first:=get_ticks;
+
+       { this estimates calibration }
+       while get_ticks=first do
+         inc(calibration);
+
+       { calculate this to ms }
+       { calibration:=calibration div 70; }
+       { this is a very bad estimation because }
+       { the loop above calls a function       }
+       { and the dealy loop does not           }
+       calibration:=calibration div 3;
+
+       { The ideal guess value is about half of the real value      }
+       { although a value lower than that take a large performance  }
+       { hit compared to a value higher than that because it has to }
+       { go through the loop a few times.                           }
+
+       if calibration<(threshold+1)*2 then
+          calibration:=(threshold+1)*2;
+          
+       { If calibration is not at least this value, an }
+       { infinite loop will result.                    }
+
+       repeat
+          incval:=calibration;
+          if calibration<0 then
+            begin
+               calibration:=$7FFFFFFF;
+               exit;
+            end;
+          { If calibration becomes less than 0, then    }
+          { the maximum value was not long enough, so   }
+          { assign it the maximum value and exit.       }
+          { Without this code, an infinite loop would   }
+          { result on superfast computers about 315800  }
+          { times faster (oh yeah!) than my Pentium 75. }
+          { If you don't think that will happen, take   }
+          { out the if and save a few clock cycles.     }
+
+          too_small:=true;     { Assumed true at beginning }
+
+          while incval>threshold do
+            begin
+               incval:=incval div 2;
+               first:=get_ticks;
+               while get_ticks=first do
+                 begin
+                 end;
+               first:=get_ticks;
+               delay(55);
+               if first=get_ticks then
+                 begin
+                    calibration:=calibration+incval;
+                 end
+               else
+                 begin
+                    calibration:=calibration-incval;
+                    too_small:=false;
+                    { If you have to decrement calibration,  }
+                    { the initial value was not too small to }
+                    { result in an accurate measurement.     }
+                 end;
+            end;
+       until not too_small;
+    end;
+
+
+  procedure textmode(mode : integer);
+
+    var
+       set_font8x8 : boolean;
+
+    begin
+       lastmode:=mode;
+       set_font8x8:=(mode and font8x8)<>0;
+       mode:=mode and $ff;
+       setscreenmode(mode);
+       windmin:=0;
+       windmax:=(screencols-1) or ((screenrows-1) shl 8);
+       maxcols:=screencols;
+       maxrows:=screenrows;
+    end;
+
+var
+   col,row : longint;
+
+begin
+   is_last:=false;
+
+   { load system variables to temporary variables to save time }
+   maxcols:=screencols;
+   maxrows:=screenrows;
+
+   { set output window }
+   windmax:=(maxcols-1) or ((maxrows-1) shl 8);
+
+   { save the current settings to restore the old state after the exit }
+   screengetcursor(row,col);
+   dosmemget($b800,get_addr(row+1,col+1)+1,startattrib,1);
+   lastmode:=getscreenmode;
+   textattr:=startattrib;
+
+   { redirect the standard output }
+   assigncrt(Output);
+   TextRec(Output).mode:=fmOutput;
+{$IFDEF GO32V2}
+   assigncrt(Input);
+   TextRec(Input).mode:=fmInput;
+{$ENDIF GO32V2}
+
+   { calculates delay calibration }
+   initdelay;
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:41  root
+  Initial revision
+
+  Revision 1.8  1998/01/26 11:56:39  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/dos/crt.pp
+  description:
+  ----------------------------
+  revision 1.7
+  date: 1998/01/07 09:24:18;  author: michael;  state: Exp;  lines: +7 -2
+  * Bug fixed in initdelay, avoiding possible infiniteloop.
+  ----------------------------
+  revision 1.6
+  date: 1998/01/06 00:29:28;  author: michael;  state: Exp;  lines: +2 -2
+  Implemented a system independent sequence of reset/rewrite/append fileopenfunc etc system \n (from Peter Vreman)
+  ----------------------------
+  revision 1.5
+  date: 1998/01/05 16:52:15;  author: michael;  state: Exp;  lines: +7 -3
+  + Minor change making use of new GO32V2 feature (From Peter Vreman)
+  ----------------------------
+  revision 1.4
+  date: 1998/01/05 13:47:01;  author: michael;  state: Exp;  lines: +199 -127
+  * Bug fixes by Peter Vreman ([email protected]), discovered
+    when writing CRT examples.
+    Bug fix from mailing list also applied.
+  ----------------------------
+  revision 1.3
+  date: 1997/12/12 13:14:36;  author: pierre;  state: Exp;  lines: +33 -12
+     + added handling of swap_vectors if under exceptions
+       i.e. swapvector is not dummy under go32v2
+     * bug in output, exceptions where not allways reset correctly
+       now the code in dpmiexcp is called from v2prt0.as exit routine
+     * in crt.pp corrected init_delay calibration loop
+       and added it for go32v2 also (was disabled before due to crashes !!)
+       the previous code did a wrong assumption on the time need to call
+       get_ticks compared to an internal loop without call
+  ----------------------------
+  revision 1.2
+  date: 1997/12/01 12:15:44;  author: michael;  state: Exp;  lines: +11 -5
+  + added copyright reference in header.
+  ----------------------------
+  revision 1.1
+  date: 1997/11/27 08:33:49;  author: michael;  state: Exp;
+  Initial revision
+  ----------------------------
+  revision 1.1.1.1
+  date: 1997/11/27 08:33:49;  author: michael;  state: Exp;  lines: +0 -0
+  FPC RTL CVS start
+  =============================================================================
+}

rtl/dos/dos.pp

@@ -0,0 +1,1174 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+
+{ to be able to cross compile from v1 to v2 }
+
+{$I os.inc}
+
+{
+  History:
+  2.7.1994: Version 0.2
+            Datenstrukturen sind deklariert sowie
+            50 % der Unterprogramme sind implementiert
+  12.8.1994: exec implemented
+  14.8.1994: findfirst and findnext implemented
+  24.8.1994: Version 0.3
+  28.2.1995: Version 0.31
+             some parameter lists with const optimized
+   3.7.1996: bug in fsplit removed (dir and ext were not intializised)
+   7.7.1996: packtime and unpacktime implemented
+  20.9.1996: Version 0.5
+             setftime and getftime implemented
+             some optimizations done (integer -> longint)
+             procedure fsearch from the LINUX version ported
+             msdos call implemented
+  26th november 1996:
+             better fexpand
+  29th january 1997:
+             bug in getftime and setftime removed
+             setfattr and getfattr added
+   2th february 1997: Version 0.9
+             bug of searchrec corrected
+  30th may 1997:
+             bug in fsplit fixed (thanks to Pierre Muller):
+               If you have a relative path as argument
+               fsplit gives a wrong result because it
+               first tries to find the extension by searching the first
+               occurence of '.'.
+
+               The file extension should be tested last !!
+  15th june 1997:
+             versions for go32v1 and go32v2 merged
+  september 1997:
+             removed some bugs for go32v2
+             - searchrec structure is different (direct dos call !!)
+  27th november 1997:
+             bug in findfirst fixed esp was instead of ebp used
+}
+
+{$ifndef GO32V2}
+{$ifdef DOS}
+{$define GO32V1}
+{$endif DOS}
+{$endif not GO32V2}
+
+unit dos;
+
+  interface
+
+    uses
+       strings
+{$ifdef GO32V2}
+       ,go32
+{$endif GO32V2}
+       ;
+
+    const
+       { bit masks for CPU flags}
+       fcarry = $0001;
+       fparity = $0004;
+       fauxiliary = $0010;
+       fzero = $0040;
+       fsign = $0080;
+       foverflow  = $0800;
+
+       { bit masks for file attributes }
+       readonly = $01;
+       hidden = $02;
+       sysfile = $04;
+       volumeid = $08;
+       directory = $10;
+       archive = $20;
+       anyfile = $3F;
+       fmclosed = $D7B0;
+       fminput = $D7B1;
+       fmoutput = $D7B2;
+       fminout = $D7B3;
+
+    type
+       { some string types }
+       comstr = string[127];        { command line string }
+       pathstr = string[79];        { string for a file path }
+       dirstr = string[67];         { string for a directory }
+       namestr = string[8];         { string for a file name }
+       extstr = string[4];          { string for an extension }
+
+       { search record which is used by findfirst and findnext }
+{$ifndef GO32V2}
+{$PACKRECORDS 1}
+       searchrec = record
+          fill : array[1..21] of byte;
+          attr : byte;
+          time : longint;
+          reserved : word; { requires the DOS extender (DJ GNU-C) }
+          size : longint;
+          name : string[15]; { the same size as declared by (DJ GNU C) }
+       end;
+{$else GO32V2}
+{$PACKRECORDS 1}
+       searchrec = record
+          fill : array[1..21] of byte;
+          attr : byte;
+          time : longint;
+          { reserved : word; not in DJGPP V2 }
+          size : longint;
+          name : string[12]; { the same size as declared by (DJ GNU C) }
+       end;
+{$endif GO32V2}
+{$PACKRECORDS 2}
+
+       { file record for untyped files comes from filerec.inc}
+       {$i filerec.inc}
+
+       { file record for text files  comes from textrec.inc}
+       {$i textrec.inc}
+
+{$ifdef GO32V1}
+       { data structure for the registers needed by msdos and intr }
+       { Go32 V2 follows trealregs of go32 }
+
+       registers = record
+         case i : integer of
+            0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
+            1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
+            2 : (eax,  ebx,  ecx,  edx,  ebp,  esi,  edi : longint);
+       end;
+{$endif GO32V1}
+
+{$ifdef GO32V2}
+       { data structure for the registers needed by msdos and intr }
+       { Go32 V2 follows trealregs of go32 }
+
+       registers = go32.registers;
+
+{$endif GO32V2}
+
+{$PACKRECORDS 1}
+       { record for date and time }
+       datetime = record
+          year,month,day,hour,min,sec : word;
+       end;
+
+    var
+       { error variable }
+       doserror : integer;
+
+    procedure getdate(var year,month,day,dayofweek : word);
+    procedure gettime(var hour,minute,second,sec100 : word);
+    function dosversion : word;
+    procedure setdate(year,month,day : word);
+    procedure settime(hour,minute,second,sec100 : word);
+    procedure getcbreak(var breakvalue : boolean);
+    procedure setcbreak(breakvalue : boolean);
+    procedure getverify(var verify : boolean);
+    procedure setverify(verify : boolean);
+    function diskfree(drive : byte) : longint;
+    function disksize(drive : byte) : longint;
+    procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
+    procedure findnext(var f : searchRec);
+
+    { is a dummy for go32v1 not for go32v2 }
+    procedure swapvectors;
+
+{   not supported:
+    procedure getintvec(intno : byte;var vector : pointer);
+    procedure setintvec(intno : byte;vector : pointer);
+    procedure keep(exitcode : word);
+}
+    procedure msdos(var regs : registers);
+    procedure intr(intno : byte;var regs : registers);
+
+    procedure getfattr(var f;var attr : word);
+    procedure setfattr(var f;attr : word);
+
+    function fsearch(const path : pathstr;dirlist : string) : pathstr;
+    procedure getftime(var f;var time : longint);
+    procedure setftime(var f;time : longint);
+    procedure packtime (var d: datetime; var time: longint);
+    procedure unpacktime (time: longint; var d: datetime);
+    function fexpand(const path : pathstr) : pathstr;
+    procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;
+      var ext : extstr);
+    procedure exec(const path : pathstr;const comline : comstr);
+    function dosexitcode : word;
+    function envcount : longint;
+    function envstr(index : longint) : string;
+    function getenv(const envvar : string): string;
+
+  implementation
+
+    var
+       dosregs : registers;
+
+    { this was first written for the LINUX version,    }
+    { by Michael Van Canneyt but it works also         }
+    { for the DOS version (I hope so)                  }
+    function fsearch(const path : pathstr;dirlist : string) : pathstr;
+
+      var
+         newdir : pathstr;
+         i,p1 : byte;
+         s : searchrec;
+
+      begin
+         if (pos('?',path)<>0) or (pos('*',path)<>0) then
+           { No wildcards allowed in these things }
+           fsearch:=''
+         else
+           begin
+              { allow slash as backslash }
+              for i:=1 to length(dirlist) do
+                if dirlist[i]='/' then dirlist[i]:='\';
+
+              repeat
+                { get first path }
+                p1:=pos(';',dirlist);
+                if p1>0 then
+                  begin
+                     newdir:=copy(dirlist,1,p1-1);
+                     delete(dirlist,1,p1)
+                  end
+                else
+                  begin
+                     newdir:=dirlist;
+                     dirlist:=''
+                  end;
+                if (newdir[length(newdir)]<>'\') and
+                   (newdir[length(newdir)]<>':') then
+                   newdir:=newdir+'\';
+                findfirst(newdir+path,anyfile,s);
+                if doserror=0 then
+                  begin
+                     { this should be newdir:=newdir+path
+                     because path can contain a path part !! }
+                     {newdir:=newdir+s.name;}
+                     newdir:=newdir+path;
+                     { this was for LINUX:
+                     if pos('.\',newdir)=1 then
+                       delete(newdir, 1, 2)
+                      DOS strips off an initial .\
+                     }
+                  end
+                else newdir:='';
+              until(dirlist='') or (length(newdir)>0);
+              fsearch:=newdir;
+           end;
+      end;
+
+    procedure getftime(var f;var time : longint);
+
+      begin
+         dosregs.bx:=textrec(f).handle;
+         dosregs.ax:=$5700;
+         msdos(dosregs);
+         time:=(dosregs.dx shl 16)+dosregs.cx;
+         doserror:=dosregs.al;
+      end;
+
+   procedure setftime(var f;time : longint);
+
+      begin
+         dosregs.bx:=textrec(f).handle;
+         dosregs.ecx:=time;
+         dosregs.ax:=$5701;
+         msdos(dosregs);
+         doserror:=dosregs.al;
+      end;
+
+    procedure msdos(var regs : registers);
+
+      begin
+         intr($21,regs);
+      end;
+{$ifdef GO32V2}
+    procedure intr(intno : byte;var regs : registers);
+
+      begin
+         realintr(intno,regs);
+      end;
+{$else GO32V2}
+    procedure intr(intno : byte;var regs : registers);
+
+      begin
+         asm
+            .data
+    int86:
+            .byte        0xcd
+    int86_vec:
+            .byte        0x03
+            jmp        int86_retjmp
+
+            .text
+            movl        8(%ebp),%eax
+            movb        %al,int86_vec
+
+            movl        10(%ebp),%eax
+            // do not use first int
+            addl        $2,%eax
+
+            movl        4(%eax),%ebx
+            movl        8(%eax),%ecx
+            movl        12(%eax),%edx
+            movl        16(%eax),%ebp
+            movl        20(%eax),%esi
+            movl        24(%eax),%edi
+            movl        (%eax),%eax
+
+            jmp        int86
+    int86_retjmp:
+            pushf
+            pushl	%ebp
+            pushl       %eax
+            movl        %esp,%ebp
+            // calc EBP new
+            addl        $12,%ebp
+            movl        10(%ebp),%eax
+            // do not use first int
+            addl        $2,%eax
+
+            popl        (%eax)
+            movl        %ebx,4(%eax)
+            movl        %ecx,8(%eax)
+            movl        %edx,12(%eax)
+            // restore EBP
+            popl	%edx
+            movl	%edx,16(%eax)
+            movl        %esi,20(%eax)
+            movl        %edi,24(%eax)
+            // ignore ES and DS
+            popl        %ebx        /* flags */
+            movl        %ebx,32(%eax)
+            // FS and GS too
+         end;
+      end;
+{$endif GO32V2}
+    var
+       lastdosexitcode : word;
+{$ifdef GO32V2}
+
+    { this code is just the most basic part of dosexec.c from
+    the djgpp code }
+
+    procedure exec(const path : pathstr;const comline : comstr);
+
+      procedure do_system(p,c : string);
+
+      {
+        Table 0931
+        Format of EXEC parameter block for AL=00h,01h,04h:
+        Offset	Size	Description
+         00h	WORD	segment of environment to copy for child process (copy caller's
+		          environment if 0000h)
+         this does not seem to work (PM)
+         02h	DWORD	pointer to command tail to be copied into child's PSP
+         06h	DWORD	pointer to first FCB to be copied into child's PSP
+         0Ah	DWORD	pointer to second FCB to be copied into child's PSP
+         0Eh	DWORD	(AL=01h) will hold subprogram's initial SS:SP on return
+         12h	DWORD	(AL=01h) will hold entry point (CS:IP) on return
+        INT 21 4B--
+
+        Copied from Ralf Brown's Interrupt List
+      }
+
+      type
+         realptr = record
+	    ofs,seg : word;
+  	 end;
+
+         texecblock = record
+	    envseg : word;
+	    comtail : realptr;
+	    firstFCB : realptr;
+	    secondFCB : realptr;
+	    iniStack : realptr;
+	    iniCSIP : realptr;
+ 	 end;
+
+      var current_dos_buffer_pos : longint;
+      function paste_to_dos(src : string) : boolean;
+        var c : array[0..255] of char;
+        begin
+           paste_to_dos:=false;
+           if current_dos_buffer_pos+length(src)+1>transfer_buffer+tb_size then
+             begin
+              doserror:=200;{ what value should we use here ? }
+              exit;
+             end;
+           move(src[1],c[0],length(src));
+           c[length(src)]:=#0;
+           seg_move(get_ds,longint(@c),dosmemselector,current_dos_buffer_pos,length(src)+1);
+           current_dos_buffer_pos:=current_dos_buffer_pos+length(src)+1;
+           paste_to_dos:=true;
+        end;
+      var
+         i,la_env,la_p,la_c,la_e,fcb1_la,fcb2_la : longint;
+         arg_ofs : longint;
+	      execblock : texecblock;
+
+      begin
+         la_env:=transfer_buffer;
+         while (la_env mod 16)<>0 do inc(la_env);
+         current_dos_buffer_pos:=la_env;
+         for i:=1 to envcount do
+           begin
+              paste_to_dos(envstr(i));
+           end;
+         paste_to_dos(''); { adds a double zero at the end }
+         { allow slash as backslash }
+         for i:=1 to length(p) do
+           if p[i]='/' then p[i]:='\';
+         la_p:=current_dos_buffer_pos;
+         paste_to_dos(p);
+         la_c:=current_dos_buffer_pos;
+         paste_to_dos(c);
+	      la_e:=current_dos_buffer_pos;
+         fcb1_la:=la_e;
+         la_e:=la_e+16;
+         fcb2_la:=la_e;
+         la_e:=la_e+16;
+         { allocate FCB see dosexec code }
+         dosregs.ax:=$2901;
+         arg_ofs:=1;
+         while (c[arg_ofs]=' ') or (c[arg_ofs]=#9) do inc(arg_ofs);
+         dosregs.ds:=(la_c+arg_ofs) div 16;
+         dosregs.si:=(la_c+arg_ofs) mod 16;
+         dosregs.es:=fcb1_la div 16;
+         dosregs.di:=fcb1_la mod 16;
+         msdos(dosregs);
+         repeat
+            inc(arg_ofs);
+         until (c[arg_ofs]=' ') or
+               (c[arg_ofs]=#9) or
+               (c[arg_ofs]=#13);
+         if c[arg_ofs]<>#13 then
+           begin
+              inc(arg_ofs);
+              while (c[arg_ofs]=' ') or (c[arg_ofs]=#9) do inc(arg_ofs);
+           end;
+         { allocate second FCB see dosexec code }
+         dosregs.ax:=$2901;
+         dosregs.ds:=(la_c+arg_ofs) div 16;
+         dosregs.si:=(la_c+arg_ofs) mod 16;
+         dosregs.es:=fcb2_la div 16;
+         dosregs.di:=fcb2_la mod 16;
+         msdos(dosregs);
+     	   with execblock do
+      	  begin
+      	     envseg:=la_env div 16;
+      	     comtail.seg:=la_c div 16;
+      	     comtail.ofs:=la_c mod 16;
+      	     firstFCB.seg:=fcb1_la div 16;
+      	     firstFCB.ofs:=fcb1_la mod 16;
+      	     secondFCB.seg:=fcb2_la div 16;
+      	     secondFCB.ofs:=fcb2_la mod 16;
+      	  end;
+       	seg_move(get_ds,longint(@execblock),dosmemselector,la_e,sizeof(texecblock));
+         dosregs.edx:=la_p mod 16;
+         dosregs.ds:=la_p div 16;
+         dosregs.ebx:=la_e mod 16;
+         dosregs.es:=la_e div 16;
+         dosregs.ax:=$4b00;
+         msdos(dosregs);
+         if (dosregs.flags and 1) <> 0 then
+           begin
+              doserror:=dosregs.ax;
+   	        lastdosexitcode:=0;
+              exit;
+           end
+         else
+           begin
+              dosregs.ax:=$4d00;
+              msdos(dosregs);
+              lastdosexitcode:=dosregs.al;
+           end;
+        end;
+
+      { var
+         p,c : array[0..255] of char; }
+        var  c : string;
+      begin
+         doserror:=0;
+         { move(path[1],p,length(path));
+         p[length(path)]:=#0; }
+         move(comline[0],c[1],length(comline)+1);
+         c[length(comline)+2]:=#13;
+         c[0]:=char(length(comline)+2);
+         do_system(path,c);
+      end;
+
+{$else GO32V2}
+
+    procedure exec(const path : pathstr;const comline : comstr);
+
+      procedure do_system(p : pchar);
+        begin
+           asm
+              movl 12(%ebp),%ebx
+              movw $0xff07,%ax
+              int $0x21
+              movw %ax,_LASTDOSEXITCODE
+           end;
+        end;
+
+      var
+         i : longint;
+         execute : string;
+         b : array[0..255] of char;
+
+      begin
+         doserror:=0;
+         execute:=path+' '+comline;
+         { allow slash as backslash for the program name only }
+         for i:=1 to length(path) do
+           if execute[i]='/' then execute[i]:='\';
+         move(execute[1],b,length(execute));
+         b[length(execute)]:=#0;
+         do_system(b);
+      end;
+
+{$endif GO32V2}
+
+    function dosexitcode : word;
+
+      begin
+         dosexitcode:=lastdosexitcode;
+      end;
+
+    function dosversion : word;
+
+      begin
+         dosregs.ax:=$3000;
+         msdos(dosregs);
+         dosversion:=dosregs.ax;
+      end;
+
+    procedure getdate(var year,month,day,dayofweek : word);
+
+      begin
+         dosregs.ax:=$2a00;
+         msdos(dosregs);
+         dayofweek:=dosregs.al;
+         year:=dosregs.cx;
+         month:=dosregs.dh;
+         day:=dosregs.dl;
+      end;
+
+    procedure setdate(year,month,day : word);
+
+      begin
+         dosregs.cx:=year;
+         dosregs.dx:=month*$100+day;
+         dosregs.ah:=$2b;
+         msdos(dosregs);
+         doserror:=dosregs.al;
+      end;
+
+    procedure gettime(var hour,minute,second,sec100 : word);
+
+      begin
+         dosregs.ah:=$2c;
+         msdos(dosregs);
+         hour:=dosregs.ch;
+         minute:=dosregs.cl;
+         second:=dosregs.dh;
+         sec100:=dosregs.dl;
+      end;
+
+    procedure settime(hour,minute,second,sec100 : word);
+
+      begin
+         dosregs.cx:=hour*$100+minute;
+         dosregs.dx:=second*$100+sec100;
+         dosregs.ah:=$2d;
+         msdos(dosregs);
+         doserror:=dosregs.al;
+      end;
+
+    procedure getcbreak(var breakvalue : boolean);
+
+      begin
+         dosregs.ax:=$3300;
+         msdos(dosregs);
+         breakvalue:=dosregs.dl<>0;
+      end;
+
+    procedure setcbreak(breakvalue : boolean);
+
+      begin
+         dosregs.ax:=$3301;
+         dosregs.dl:=ord(breakvalue);
+         msdos(dosregs);
+      end;
+
+    procedure getverify(var verify : boolean);
+
+      begin
+         dosregs.ah:=$54;
+         msdos(dosregs);
+         verify:=dosregs.al<>0;
+      end;
+
+    procedure setverify(verify : boolean);
+
+      begin
+         dosregs.ah:=$2e;
+         dosregs.al:=ord(verify);
+         msdos(dosregs);
+      end;
+
+    function diskfree(drive : byte) : longint;
+
+      begin
+         dosregs.dl:=drive;
+         dosregs.ah:=$36;
+         msdos(dosregs);
+         if dosregs.ax<>$FFFF then
+           begin
+              diskfree:=dosregs.ax;
+              diskfree:=diskfree*dosregs.bx;
+              diskfree:=diskfree*dosregs.cx;
+           end
+         else
+           diskfree:=-1;
+      end;
+
+    function disksize(drive : byte) : longint;
+
+      begin
+         dosregs.dl:=drive;
+         dosregs.ah:=$36;
+         msdos(dosregs);
+         if dosregs.ax<>$FFFF then
+           begin
+              disksize:=dosregs.ax;
+              disksize:=disksize*dosregs.cx;
+              disksize:=disksize*dosregs.dx;
+           end
+         else
+           disksize:=-1;
+      end;
+
+    procedure searchrec2dossearchrec(var f : searchrec);
+
+      var
+         l,i : longint;
+
+      begin
+         l:=length(f.name);
+         for i:=1 to 12 do
+           f.name[i-1]:=f.name[i];
+         f.name[l]:=#0;
+      end;
+
+    procedure dossearchrec2searchrec(var f : searchrec);
+
+      var
+         l,i : longint;
+
+      begin
+         l:=12;
+         for i:=0 to 12 do
+           if f.name[i]=#0 then
+             begin
+                l:=i;
+                break;
+             end;
+         for i:=11 downto 0 do
+           f.name[i+1]:=f.name[i];
+         f.name[0]:=chr(l);
+      end;
+
+    procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
+
+{$ifdef GO32V2}
+
+      procedure _findfirst(path : pchar;attr : word;var f : searchrec);
+
+        var
+           i : longint;
+        begin
+           { allow slash as backslash }
+           for i:=0 to strlen(path) do
+             if path[i]='/' then path[i]:='\';
+           copytodos(f,sizeof(searchrec));
+           dosregs.edx:=transfer_buffer mod 16;
+           dosregs.ds:=transfer_buffer div 16;
+           dosregs.ah:=$1a;
+           msdos(dosregs);
+           dosregs.ecx:=attr;
+           dosregs.edx:=(transfer_buffer mod 16) + Sizeof(searchrec)+1;
+           dosmemput(transfer_buffer div 16,
+             (transfer_buffer mod 16) +Sizeof(searchrec)+1,path^,strlen(path)+1);
+           dosregs.ds:=transfer_buffer div 16;
+	   dosregs.ah:=$4e;
+           msdos(dosregs);
+           copyfromdos(f,sizeof(searchrec));
+           if dosregs.flags and carryflag<>0 then
+             doserror:=dosregs.ax;
+        end;
+
+{$else GO32V2}
+
+      procedure _findfirst(path : pchar;attr : word;var f : searchrec);
+
+        var
+           i : longint;
+        begin
+           { allow slash as backslash }
+           for i:=0 to strlen(path) do
+             if path[i]='/' then path[i]:='\';
+           asm
+              movl 18(%ebp),%edx
+              movb $0x1a,%ah
+              int $0x21
+              movl 12(%ebp),%edx
+              movzwl 16(%ebp),%ecx
+              movb $0x4e,%ah
+              int $0x21
+              jnc .LFF
+              movw %ax,U_DOS_DOSERROR
+           .LFF:
+           end;
+        end;
+
+{$endif GO32V2}
+
+      var
+         path0 : array[0..80] of char;
+
+      begin
+         { no error }
+         doserror:=0;
+         strpcopy(path0,path);
+         _findfirst(path0,attr,f);
+         dossearchrec2searchrec(f);
+      end;
+
+    procedure findnext(var f : searchRec);
+
+{$ifdef GO32V2}
+
+      procedure _findnext(var f : searchrec);
+
+        begin
+           copytodos(f,sizeof(searchrec));
+           dosregs.edx:=transfer_buffer mod 16;
+           dosregs.ds:=transfer_buffer div 16;
+	        dosregs.ah:=$1a;
+           msdos(dosregs);
+	        dosregs.ah:=$4f;
+           msdos(dosregs);
+           copyfromdos(f,sizeof(searchrec));
+           if dosregs.flags and carryflag <> 0 then
+             doserror:=dosregs.ax;
+        end;
+
+{$else GO32V2}
+
+      procedure _findnext(var f : searchrec);
+
+        begin
+           asm
+              movl 12(%ebp),%edx
+              movb $0x1a,%ah
+              int $0x21
+              movb $0x4f,%ah
+              int $0x21
+              jnc .LFN
+              movw %ax,U_DOS_DOSERROR
+           .LFN:
+           end;
+        end;
+
+{$endif GO32V2}
+
+      begin
+         { no error }
+         doserror:=0;
+         searchrec2dossearchrec(f);
+         _findnext(f);
+         dossearchrec2searchrec(f);
+      end;
+
+    procedure swapvectors;
+
+{$ifdef go32v2}
+{ uses four global symbols from v2prt0.as
+  to be able to know the current exception state
+  without using dpmiexcp unit }
+      begin
+         asm
+            movl _exception_exit,%eax
+            orl  %eax,%eax
+            je   .Lno_excep
+            movl _v2prt0_exceptions_on,%eax
+            orl  %eax,%eax
+            je   .Lexceptions_off
+            movl _swap_out,%eax
+            call *%eax
+            jmp  .Lno_excep
+         .Lexceptions_off:
+            movl _swap_in,%eax
+            call *%eax
+         .Lno_excep:
+         end;
+      end;
+{$else not go32v2}
+      begin
+         { only a dummy }
+      end;
+{$endif go32v2}
+
+    type
+       ppchar = ^pchar;
+
+{$ifdef GO32V1}
+
+    function envs : ppchar;
+
+      begin
+         asm
+            movl _environ,%eax
+            leave
+            ret
+         end ['EAX'];
+      end;
+
+{$endif}
+
+    function envcount : longint;
+
+      var
+         hp : ppchar;
+
+      begin
+{$ifdef GO32V2}
+         hp:=environ;
+{$else GO32V2}
+         hp:=envs;
+{$endif}
+         envcount:=0;
+         while assigned(hp^) do
+           begin
+              { not the best solution, but quite understandable }
+              inc(envcount);
+              hp:=hp+4;
+           end;
+      end;
+
+    function envstr(index : longint) : string;
+
+      var
+         hp : ppchar;
+
+      begin
+         if (index<=0) or (index>envcount) then
+           begin
+              envstr:='';
+              exit;
+           end;
+{$ifdef GO32V2}
+         hp:=environ+4*(index-1);
+{$else GO32V2}
+         hp:=envs+4*(index-1);
+{$endif GO32V2}
+         envstr:=strpas(hp^);
+      end;
+
+    function getenv(const envvar : string) : string;
+
+      var
+         hs,_envvar : string;
+         eqpos,i : longint;
+
+      begin
+         _envvar:=upcase(envvar);
+         getenv:='';
+         for i:=1 to envcount do
+           begin
+              hs:=envstr(i);
+              eqpos:=pos('=',hs);
+              if copy(hs,1,eqpos-1)=_envvar then
+                begin
+                   getenv:=copy(hs,eqpos+1,length(hs)-eqpos);
+                   exit;
+                end;
+           end;
+      end;
+
+    procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;
+      var ext : extstr);
+
+      var
+         p1 : byte;
+         i : longint;
+      begin
+         { allow slash as backslash }
+         for i:=1 to length(path) do
+             if path[i]='/' then path[i]:='\';
+         { get drive name }
+         p1:=pos(':',path);
+         if p1>0 then
+           begin
+              dir:=path[1]+':';
+              delete(path,1,p1);
+           end
+         else
+           dir:='';
+         { split the path and the name, there are no more path informtions }
+         { if path contains no backslashes                                 }
+         while true do
+           begin
+              p1:=pos('\',path);
+              if p1=0 then
+                break;
+              dir:=dir+copy(path,1,p1);
+              delete(path,1,p1);
+           end;
+         { try to find out a extension }
+         p1:=pos('.',path);
+         if p1>0 then
+           begin
+              ext:=copy(path,p1,4);
+              delete(path,p1,length(path)-p1+1);
+           end
+         else
+           ext:='';
+         name:=path;
+      end;
+
+    function fexpand(const path : pathstr) : pathstr;
+
+      function get_current_drive : byte;
+      
+        var
+           r : registers;
+           
+        begin
+           r.ah:=$19;
+           msdos(r);
+           get_current_drive:=r.al;
+        end;           
+
+       var
+          s,pa : string[79];
+          i,j : byte;
+
+       begin
+          { There are differences between FPKPascal and Turbo Pascal
+            e.g. for the string 'D:\DEMO\..\HELLO' which isn't handled }
+          getdir(0,s);
+          pa:=upcase(path);
+          { allow slash as backslash }
+          for i:=1 to length(pa) do
+             if pa[i]='/' then pa[i]:='\';
+          if (ord(pa[0])>1) and (((pa[1]>='A') and (pa[1]<='Z')) and (pa[2]=':')) then
+            begin
+               { we must get the right directory }
+               getdir(ord(pa[1])-ord('A')+1,s);
+               if (ord(pa[0])>2) and (pa[3]<>'\') then
+                 if pa[1]=s[1] then
+                   pa:=s+'\'+copy (pa,3,length(pa))
+                 else
+                   pa:=pa[1]+':\'+copy (pa,3,length(pa))
+            end
+          else
+            if pa[1]='\' then 
+              pa:=s[1]+':'+pa
+            else if s[0]=#3 then
+              pa:=s+pa
+            else
+              pa:=s+'\'+pa;
+        {First remove all references to '\.\'}
+          while pos ('\.\',pa)<>0 do
+           delete (pa,pos('\.\',pa),2);
+        {Now remove also all references to '\..\' + of course previous dirs..}
+          repeat
+            i:=pos('\..\',pa);
+            if i<>0 then j:=i-1;
+            while (j>1) and (pa[j]<>'\') do
+             dec (j);
+            delete (pa,j,i-j+3);
+          until i=0;
+        {Remove End . and \}
+          if (length(pa)>0) and (pa[length(pa)]='.') then
+           dec(byte(pa[0]));
+          if (length(pa)>0) and (pa[length(pa)]='\') then
+           dec(byte(pa[0]));
+          fexpand:=pa;
+       end;
+
+     procedure packtime(var d : datetime;var time : longint);
+
+       var
+          zs : longint;
+
+       begin
+          time:=-1980;
+          time:=time+d.year and 127;
+          time:=time shl 4;
+          time:=time+d.month;
+          time:=time shl 5;
+          time:=time+d.day;
+          time:=time shl 16;
+          zs:=d.hour;
+          zs:=zs shl 6;
+          zs:=zs+d.min;
+          zs:=zs shl 5;
+          zs:=zs+d.sec div 2;
+          time:=time+(zs and $ffff);
+       end;
+
+     procedure unpacktime (time: longint; var d: datetime);
+
+       begin
+          d.sec:=(time and 31) * 2;
+          time:=time shr 5;
+          d.min:=time and 63;
+          time:=time shr 6;
+          d.hour:=time and 31;
+          time:=time shr 5;
+          d.day:=time and 31;
+          time:=time shr 5;
+          d.month:=time and 15;
+          time:=time shr 4;
+          d.year:=time + 1980;
+       end;
+
+{$ifdef GO32V2}
+
+    procedure getfattr(var f;var attr : word);
+
+      var
+         r : registers;
+
+      begin
+         copytodos(filerec(f).name,strlen(filerec(f).name)+1);
+         r.ax:=$4300;
+         r.edx:=transfer_buffer mod 16;
+         r.ds:=transfer_buffer div 16;
+         msdos(r);
+         if (r.flags and carryflag) <> 0 then
+           doserror:=r.ax;
+         attr:=r.cx;
+      end;
+
+    procedure setfattr(var f;attr : word);
+
+      var
+         r : registers;
+
+      begin
+         copytodos(filerec(f).name,strlen(filerec(f).name)+1);
+         r.ax:=$4301;
+         r.edx:=transfer_buffer mod 16;
+         r.ds:=transfer_buffer div 16;
+         r.cx:=attr;
+         msdos(r);
+         if (r.flags and carryflag) <> 0 then
+           doserror:=r.ax;
+      end;
+
+{$else GO32V2}
+
+    procedure getfattr(var f;var attr : word);
+
+      var
+         { to avoid problems }
+         n : array[0..255] of char;
+         r : registers;
+
+      begin
+         strpcopy(n,filerec(f).name);
+         r.ax:=$4300;
+         r.edx:=longint(@n);
+         msdos(r);
+         attr:=r.cx;
+      end;
+
+    procedure setfattr(var f;attr : word);
+
+      var
+         { to avoid problems }
+         n : array[0..255] of char;
+         r : registers;
+
+      begin
+         strpcopy(n,filerec(f).name);
+         r.ax:=$4301;
+         r.edx:=longint(@n);
+         r.cx:=attr;
+         msdos(r);
+      end;
+
+{$endif GO32V2}
+
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:41  root
+  Initial revision
+
+  Revision 1.10  1998/03/12 04:02:32  carl
+    * bugfix of Range Check error in FExpand
+
+  Revision 1.9  1998/02/05 12:08:48  pierre
+    * added packrecords to about dword alignment
+      for structures used in dos calls
+
+  Revision 1.8  1998/02/03 15:52:41  pierre
+    * swapvectors really disable exception handling
+      and interrupt redirection with go32v2
+    * in dos.pp bug if arg path from fsearch had a directory part fixed
+
+  Revision 1.7  1998/01/26 11:56:22  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/dos/dos.pp
+  description:
+  ----------------------------
+  revision 1.6
+  date: 1998/01/16 00:04:58;  author: michael;  state: Exp;  lines: +17 -18
+  Added some fixes of Peter Vreman
+  ----------------------------
+  revision 1.5
+  date: 1997/12/22 10:22:05;  author: pierre;  state: Exp;  lines: +2 -2
+    * bug in disksize corrected (thanks to Papai Andras)
+  ----------------------------
+  revision 1.4
+  date: 1997/12/12 13:17:15;  author: florian;  state: Exp;  lines: +3 -2
+  dos.doserror wasn't set to zero in dos.exec (go32v2)
+  ----------------------------
+  revision 1.3
+  date: 1997/12/01 12:15:45;  author: michael;  state: Exp;  lines: +12 -5
+  + added copyright reference in header.
+  ----------------------------
+  revision 1.2
+  date: 1997/11/27 22:49:03;  author: florian;  state: Exp;  lines: +6 -5
+  - CPU.PP added
+  - some bugs in DOS fixed (espsecially for go32v1)
+  - the win32 system unit is now compilable
+  ----------------------------
+  revision 1.1
+  date: 1997/11/27 08:33:49;  author: michael;  state: Exp;
+  Initial revision
+  ----------------------------
+  revision 1.1.1.1
+  date: 1997/11/27 08:33:49;  author: michael;  state: Exp;  lines: +0 -0
+  FPC RTL CVS start
+  =============================================================================
+}

rtl/dos/fmouse.pp

@@ -0,0 +1,349 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by the Free Pascal development team
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************
+}
+Unit FMouse;
+Interface
+
+{
+  Mouse support functions and procedures,with error checking if mouse
+  isn't present then the routine ends,if you want to remove error checking
+  remove the next define.
+}
+
+{$DEFINE MOUSECHECK}
+
+{check if mouse is present and sets the mouse variable}
+  Function Check_Mouse:Boolean;
+{shows mouse pointer,text+graphics screen support}
+  Procedure Show_Mouse;
+{hides mouse pointer}
+  Procedure Hide_Mouse;
+{reads mouse position in pixels,divide by 8 to get text position,and reads
+  buttons state(1-left button,2=right button,7=middle button)}
+  Procedure read_mouse (var x,y:Longint;var buttons:Longint);
+{sets mouse pointer in text mode}
+  Procedure Mouse_Cur(X,Y:Longint);
+{sets the mouse shape in text mode}
+  Procedure Mouse_Shape(BackColor,ForColor,Ascii:LongInt);
+{sets the mouse ascii in text mode}
+  Procedure Mouse_Ascii(Ascii:LongInt);
+{returns which button was pressed after last call to function}
+  Function mouse_press(var x,y:Longint;button:Longint):Longint;
+{returns which button was realeased after last call to function}
+  Function mouse_release (var row,col:Longint;button : Longint):integer;
+{set's mouse y range}
+  Procedure mouse_yrange (min,max:Longint);
+{set's mouse y range}
+  Procedure mouse_xrange (min,max:Longint);
+{set mouse speed}
+  Procedure Micky(Horizontal ,Vertical:Longint);
+{return if right button pressed}
+  Function IsRPres:Boolean;
+{return if left button pressed}
+  Function IsLPres:Boolean;
+{set rectangle on screen that mouse will disappear if will point on it}
+  Procedure Unseen_Mouse(x1,y1,x2,y2:Longint);
+{set window for mouse}
+  Procedure MWindow(x1,y1,x2,y2:Longint);
+
+Var
+  Mouse:Boolean;
+
+Implementation
+
+Function Check_Mouse:Boolean;
+begin
+  asm
+        xorl    %eax,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        cmpw    $0xffff,%ax
+        setz    %al
+        movb    %al,U_FMOUSE_MOUSE
+        movb    %al,__RESULT
+  end;
+end;
+
+
+procedure show_mouse;
+begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        movl    $1,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+  end;
+end;
+
+procedure hide_mouse;
+begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        movl    $2,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+  end;
+end;
+
+procedure read_mouse (var x,y,buttons:Longint);
+begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        movl    $3,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        andl    $0xffff,%ecx
+        andl    $0xffff,%edx
+        movl    x,%eax
+        movl    %ecx,(%eax)
+        movl    y,%eax
+        movl    %edx,(%eax)
+        movl    buttons,%eax
+        movw    %bx,(%eax)
+  end;
+end;
+
+function mouse_press(var x,y:Longint;button:Longint):Longint;
+begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        movl    $5,%eax
+        movl    button,%ebx
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        andl    $0xffff,%ecx
+        andl    $0xffff,%edx
+        movl    x,%ebx
+        movl    %ecx,(%ebx)
+        movl    y,%ebx
+        movl    %edx,(%ebx)
+        movl    %eax,__RESULT
+  end;
+end;
+
+function mouse_release (var row,col:Longint;button : Longint):integer;
+begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        movl    $6,%eax
+        movl    button,%ebx
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        andl    $0xffff,%ecx
+        andl    $0xffff,%edx
+        movl    x,%ebx
+        movl    %ecx,(%ebx)
+        movl    y,%ebx
+        movl    %edx,(%ebx)
+        movl    %eax,__RESULT
+  end;
+end;
+
+procedure mouse_yrange (min,max:Longint);
+begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        movl    $8,%eax
+        movl    min,%ecx
+        movl    max,%edx
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+  end;
+end;
+
+procedure mouse_xrange (min,max:Longint);
+begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        movl    $7,%eax
+        movl    min,%ecx
+        movl    max,%edx
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+  end;
+end;
+
+Procedure Mouse_Cur(X,Y:Longint);
+Begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        movl    $4,%eax
+        movl    X,%ecx
+        movl    Y,%edx
+        shll    $3,%ecx
+        shll    $3,%edx
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+  End;
+End;
+
+Procedure Mouse_Shape(BackColor,ForColor,Ascii:LongInt);
+Begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        xorl    %ebx,%ebx
+        movl    $0xa,%ax
+        movl    $0xff,%ecx
+        xorl    %edx,%edx
+        movb    8(%ebp),%dh
+        shlb    $4,%dh
+        addb    ForColor,%dh
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+  End;
+End;
+
+Procedure Mouse_Ascii(Ascii:LongInt);
+Begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        xorl    %ebx,%ebx
+        movl    $0xa,%eax
+        movl    $0xff00,%ecx
+        xorl    %edx,%edx
+        movb    8(%ebp),%dl
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+  End;
+End;
+
+Procedure Unseen_Mouse(x1,y1,x2,y2:Longint);
+Begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        movl    $0x0010,%eax
+        movl    x1,%ecx
+        movl    y1,%edx
+        movl    x2,%esi
+        movl    y2,%edi
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+  end;
+End;
+
+Procedure Micky(Horizontal ,Vertical:Longint);
+Begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        movl    $0x0f,%eax
+        movl    Horizontal,%ecx
+        movl    Vertical,%edx
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+  end;
+End;
+
+Function IsRPres:Boolean;
+Begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        movl    $3,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        shrl    $1,%eax
+        andl    $1,%eax
+        movb    %al,__RESULT
+  end;
+end;
+
+Function IsLPres:Boolean;
+Begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  asm
+        movl    $3,%eax
+        pushl   %ebp
+        int     $0x33
+        popl    %ebp
+        andl    $1,%eax
+        movb    %al,__RESULT
+  end;
+end;
+
+Procedure MWindow(x1,y1,x2,y2:Longint);
+Begin
+{$IFDEF MOUSECHECK}
+  If (Not Mouse) Then Exit;
+{$ENDIF}
+  mouse_xrange(x1,x2);
+  mouse_yrange(y1,y2);
+End;
+
+Begin
+  Check_Mouse;
+End.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:41  root
+  Initial revision
+
+  Revision 1.4  1998/03/24 15:53:12  peter
+    * cleanup and doesn't give warnings when compiling
+
+  Revision 1.3  1998/01/26 11:56:24  michael
+  + Added log at the end
+
+  Revision 1.2
+  date: 1997/12/01 12:15:45;  author: michael;  state: Exp;  lines: +14 -12
+  + added copyright reference in header.
+
+  Revision 1.1
+  date: 1997/11/27 08:33:49;  author: michael;  state: Exp;
+  Initial revision
+
+  Revision 1.1.1.1
+  date: 1997/11/27 08:33:49;  author: michael;  state: Exp;  lines: +0 -0
+  FPC RTL CVS start
+}

rtl/dos/go32.pp

@@ -0,0 +1,1155 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    and implements some stuff for protected mode programming
+    Copyright (c) 1993,97 by the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+
+unit go32;
+
+{$S-}{no stack check, used by DPMIEXCP !! }
+{$I os.inc}
+
+  interface
+
+    const
+    { contants for the run modes returned by get_run_mode }
+       rm_unknown = 0;
+       rm_raw     = 1;     { raw (without HIMEM) }
+       rm_xms     = 2;     { XMS (for example with HIMEM, without EMM386) }
+       rm_vcpi    = 3;     { VCPI (for example HIMEM and EMM386) }
+       rm_dpmi    = 4;     { DPMI (for example DOS box or 386Max) }
+
+    { flags }
+       carryflag     = $001;
+       parityflag    = $004;
+       auxcarryflag  = $010;
+       zeroflag      = $040;
+       signflag      = $080;
+       trapflag      = $100;
+       interruptflag = $200;
+       directionflag = $400;
+       overflowflag  = $800;
+
+    type
+       tmeminfo = record
+          available_memory,
+          available_pages,
+          available_lockable_pages,
+          linear_space,
+          unlocked_pages,
+          available_physical_pages,
+          total_physical_pages,
+          free_linear_space,
+          max_pages_in_paging_file,
+          reserved0,
+          reserved1,
+          reserved2 : longint;
+       end;
+
+       tseginfo = record
+          offset  : pointer;
+          segment : word;
+       end;
+
+       trealregs = record
+         case integer of
+          1: { 32-bit } (EDI, ESI, EBP, Res, EBX, EDX, ECX, EAX: longint;
+                         Flags, ES, DS, FS, GS, IP, CS, SP, SS: word);
+          2: { 16-bit } (DI, DI2, SI, SI2, BP, BP2, R1, R2: word;
+                         BX, BX2, DX, DX2, CX, CX2, AX, AX2: word);
+          3: { 8-bit }  (stuff: array[1..4] of longint;
+                         BL, BH, BL2, BH2, DL, DH, DL2, DH2,
+                         CL, CH, CL2, CH2, AL, AH, AL2, AH2: byte);
+          4: { Compat } (RealEDI, RealESI, RealEBP, RealRES,
+                         RealEBX, RealEDX, RealECX, RealEAX: longint;
+                         RealFlags,
+                         RealES, RealDS, RealFS, RealGS,
+                         RealIP, RealCS, RealSP, RealSS: word);
+       end;
+
+      registers = trealregs;
+
+    { this works only with real DPMI }
+    function allocate_ldt_descriptors(count : word) : word;
+    function free_ldt_descriptor(d : word) : boolean;
+    function segment_to_descriptor(seg : word) : word;
+    function get_next_selector_increment_value : word;
+    function get_segment_base_address(d : word) : longint;
+    function set_segment_base_address(d : word;s : longint) : boolean;
+    function set_segment_limit(d : word;s : longint) : boolean;
+    function create_code_segment_alias_descriptor(seg : word) : word;
+    function get_linear_addr(phys_addr : longint;size : longint) : longint;
+    function get_segment_limit(d : word) : longint;
+    function get_page_size:longint;
+    function map_device_in_memory_block(handle,offset,pagecount,device:longint):boolean;
+    function realintr(intnr : word;var regs : trealregs) : boolean;
+
+    { is needed for functions which need a real mode buffer }
+    function global_dos_alloc(bytes : longint) : longint;
+    function global_dos_free(selector : word) : boolean;
+
+    var
+       { selector for the DOS memory (only usable if in DPMI mode) }
+       dosmemselector : word;
+
+    { this procedure copies data where the source and destination }
+    { are specified by 48 bit pointers                            }
+    { Note: the procedure checks only for overlapping if          }
+    { source selector=destination selector                        }
+    procedure seg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint);
+
+    { fills a memory area specified by a 48 bit pointer with c }
+    procedure seg_fillchar(seg : word;ofs : longint;count : longint;c : char);
+    procedure seg_fillword(seg : word;ofs : longint;count : longint;w : word);
+
+    {************************************}
+    { this works with all PM interfaces: }
+    {************************************}
+
+    function get_meminfo(var meminfo : tmeminfo) : boolean;
+    function get_pm_interrupt(vector : byte;var intaddr : tseginfo) : boolean;
+    function set_pm_interrupt(vector : byte;const intaddr : tseginfo) : boolean;
+    function get_rm_interrupt(vector : byte;var intaddr : tseginfo) : boolean;
+    function set_rm_interrupt(vector : byte;const intaddr : tseginfo) : boolean;
+    function get_exception_handler(e : byte;var intaddr : tseginfo) : boolean;
+    function set_exception_handler(e : byte;const intaddr : tseginfo) : boolean;
+    function get_pm_exception_handler(e : byte;var intaddr : tseginfo) : boolean;
+    function set_pm_exception_handler(e : byte;const intaddr : tseginfo) : boolean;
+    function free_rm_callback(var intaddr : tseginfo) : boolean;
+    function get_rm_callback(pm_func : pointer;const reg : trealregs;var rmcb : tseginfo) : boolean;
+    function get_cs : word;
+    function get_ds : word;
+    function get_ss : word;
+
+    { locking functions }
+    function allocate_memory_block(size:longint):longint;
+    function free_memory_block(blockhandle : longint) : boolean;
+    function request_linear_region(linearaddr, size : longint;
+                                   var blockhandle : longint) : boolean;
+    function lock_linear_region(linearaddr, size : longint) : boolean;
+    function lock_data(var data;size : longint) : boolean;
+    function lock_code(functionaddr : pointer;size : longint) : boolean;
+    function unlock_linear_region(linearaddr, size : longint) : boolean;
+    function unlock_data(var data;size : longint) : boolean;
+    function unlock_code(functionaddr : pointer;size : longint) : boolean;
+
+    { disables and enables interrupts }
+    procedure disable;
+    procedure enable;
+
+    function inportb(port : word) : byte;
+    function inportw(port : word) : word;
+    function inportl(port : word) : longint;
+
+    procedure outportb(port : word;data : byte);
+    procedure outportw(port : word;data : word);
+    procedure outportl(port : word;data : longint);
+    function get_run_mode : word;
+
+{$ifndef V0_6}
+    function transfer_buffer : longint;
+    function tb_size : longint;
+    procedure copytodos(var addr; len : longint);
+    procedure copyfromdos(var addr; len : longint);
+{$endif not VER0_6}
+
+    procedure dpmi_dosmemput(seg : word;ofs : word;var data;count : longint);
+    procedure dpmi_dosmemget(seg : word;ofs : word;var data;count : longint);
+    procedure dpmi_dosmemmove(sseg,sofs,dseg,dofs : word;count : longint);
+    procedure dpmi_dosmemfillchar(seg,ofs : word;count : longint;c : char);
+    procedure dpmi_dosmemfillword(seg,ofs : word;count : longint;w : word);
+
+    const
+       { this procedures are assigned to the procedure which are needed }
+       { for the current mode to access DOS memory                      }
+       { It's strongly recommended to use this procedures!              }
+       dosmemput      : procedure(seg : word;ofs : word;var data;count : longint)=dpmi_dosmemput;
+       dosmemget      : procedure(seg : word;ofs : word;var data;count : longint)=dpmi_dosmemget;
+       dosmemmove     : procedure(sseg,sofs,dseg,dofs : word;count : longint)=dpmi_dosmemmove;
+       dosmemfillchar : procedure(seg,ofs : word;count : longint;c : char)=dpmi_dosmemfillchar;
+       dosmemfillword : procedure(seg,ofs : word;count : longint;w : word)=dpmi_dosmemfillword;
+
+  implementation
+
+{$ifndef go32v2}
+
+    { the following procedures copy from and to DOS memory without DPMI,
+      these are not necessary for go32v2, becuase that requires dpmi (PFV) }
+
+    procedure raw_dosmemput(seg : word;ofs : word;var data;count : longint);
+
+      begin
+         move(data,pointer($e0000000+seg*16+ofs)^,count);
+      end;
+
+    procedure raw_dosmemget(seg : word;ofs : word;var data;count : longint);
+
+      begin
+         move(pointer($e0000000+seg*16+ofs)^,data,count);
+      end;
+
+    procedure raw_dosmemmove(sseg,sofs,dseg,dofs : word;count : longint);
+
+      begin
+         move(pointer($e0000000+sseg*16+sofs)^,pointer($e0000000+dseg*16+dofs)^,count);
+      end;
+
+    procedure raw_dosmemfillchar(seg,ofs : word;count : longint;c : char);
+
+      begin
+         fillchar(pointer($e0000000+seg*16+ofs)^,count,c);
+      end;
+
+    procedure raw_dosmemfillword(seg,ofs : word;count : longint;w : word);
+
+      begin
+         fillword(pointer($e0000000+seg*16+ofs)^,count,w);
+      end;
+
+{$endif}
+
+    { the following procedures copy from and to DOS memory using DPMI }
+    procedure dpmi_dosmemput(seg : word;ofs : word;var data;count : longint);
+
+      begin
+         seg_move(get_ds,longint(@data),dosmemselector,seg*16+ofs,count);
+      end;
+
+    procedure dpmi_dosmemget(seg : word;ofs : word;var data;count : longint);
+
+      begin
+         seg_move(dosmemselector,seg*16+ofs,get_ds,longint(@data),count);
+      end;
+
+    procedure dpmi_dosmemmove(sseg,sofs,dseg,dofs : word;count : longint);
+
+      begin
+         seg_move(dosmemselector,sseg*16+sofs,dosmemselector,dseg*16+dofs,count);
+      end;
+
+    procedure dpmi_dosmemfillchar(seg,ofs : word;count : longint;c : char);
+
+      begin
+         seg_fillchar(dosmemselector,seg*16+ofs,count,c);
+      end;
+
+    procedure dpmi_dosmemfillword(seg,ofs : word;count : longint;w : word);
+
+      begin
+         seg_fillword(dosmemselector,seg*16+ofs,count,w);
+      end;
+
+    function global_dos_alloc(bytes : longint) : longint;
+
+      begin
+         asm
+            movl bytes,%ebx
+            orl  $0x10,%ebx             // round up
+            shrl $0x4,%ebx              // convert to Paragraphs
+            movl $0x100,%eax            // function 0x100
+            int  $0x31
+            shll $0x10,%eax             // return Segment in hi(Result)
+            movw %dx,%ax                // return Selector in lo(Result)
+            movl %eax,__result
+         end;
+      end;
+
+    function  global_dos_free(selector : word) : boolean;
+
+      begin
+         asm
+            movw Selector,%dx
+            movl $0x101,%eax
+            int  $0x31
+            setnc %al
+            movb %al,__RESULT
+         end;
+      end;
+
+    function realintr(intnr : word;var regs : trealregs) : boolean;
+
+      begin
+         regs.realsp:=0;
+         regs.realss:=0;
+         asm
+            movw  intnr,%bx
+            xorl  %ecx,%ecx
+            movl  regs,%edi
+            { es is always equal ds }
+            movl  $0x300,%eax
+            int   $0x31
+            setnc %al
+            movb  %al,__RESULT
+         end;
+      end;
+
+    procedure seg_fillchar(seg : word;ofs : longint;count : longint;c : char);
+
+      begin
+         asm
+            movl ofs,%edi
+            movl count,%ecx
+            movb c,%dl
+            { load es with selector }
+            pushw %es
+            movw seg,%ax
+            movw %ax,%es
+            { fill eax with duplicated c }
+            { so we can use stosl        }
+            movb %dl,%dh
+            movw %dx,%ax
+            shll $16,%eax
+            movw %dx,%ax
+            movl %ecx,%edx
+            shrl $2,%ecx
+            cld
+            rep
+            stosl
+            movl %edx,%ecx
+            andl $3,%ecx
+            rep
+            stosb
+            popw %es
+         end ['EAX','ECX','EDX','EDI'];
+      end;
+
+    procedure seg_fillword(seg : word;ofs : longint;count : longint;w : word);
+
+      begin
+         asm
+            movl ofs,%edi
+            movl count,%ecx
+            movw w,%dx
+            { load segment }
+            pushw %es
+            movw seg,%ax
+            movw %ax,%es
+            { fill eax }
+            movw %dx,%ax
+            shll $16,%eax
+            movw %dx,%ax
+            movl %ecx,%edx
+            shrl $1,%ecx
+            cld
+            rep
+            stosl
+            movl %edx,%ecx
+            andl $1,%ecx
+            rep
+            stosw
+            popw %es
+         end ['EAX','ECX','EDX','EDI'];
+      end;
+
+    procedure seg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint);
+
+      begin
+         if count=0 then
+           exit;
+         if (sseg<>dseg) or ((sseg=dseg) and (source>dest)) then
+           asm
+              pushw %es
+              pushw %ds
+              cld
+              movl count,%ecx
+              movl source,%esi
+              movl dest,%edi
+              movw dseg,%ax
+              movw %ax,%es
+              movw sseg,%ax
+              movw %ax,%ds
+              movl %ecx,%eax
+              shrl $2,%ecx
+              rep
+              movsl
+              movl %eax,%ecx
+              andl $3,%ecx
+              rep
+              movsb
+              popw %ds
+              popw %es
+           end ['ESI','EDI','ECX','EAX']
+         else if (source<dest) then
+           { copy backward for overlapping }
+           asm
+              pushw %es
+              pushw %ds
+              std
+              movl count,%ecx
+              movl source,%esi
+              movl dest,%edi
+              movw dseg,%ax
+              movw %ax,%es
+              movw sseg,%ax
+              movw %ax,%ds
+              addl %ecx,%esi
+              addl %ecx,%edi
+              movl %ecx,%eax
+              andl $3,%ecx
+              orl %ecx,%ecx
+              jz .LSEG_MOVE1
+
+              { calculate esi and edi}
+              decl %esi
+              decl %edi
+              rep
+              movsb
+              incl %esi
+              incl %edi
+           .LSEG_MOVE1:
+              subl $4,%esi
+              subl $4,%edi
+              movl %eax,%ecx
+              shrl $2,%ecx
+              rep
+              movsl
+              cld
+              popw %ds
+              popw %es
+           end ['ESI','EDI','ECX'];
+      end;
+
+    procedure outportb(port : word;data : byte);
+
+      begin
+         asm
+            movw port,%dx
+            movb data,%al
+            outb %al,%dx
+         end ['EAX','EDX'];
+      end;
+
+    procedure outportw(port : word;data : word);
+
+      begin
+         asm
+            movw port,%dx
+            movw data,%ax
+            outw %ax,%dx
+         end ['EAX','EDX'];
+      end;
+
+    procedure outportl(port : word;data : longint);
+
+      begin
+         asm
+            movw port,%dx
+            movl data,%eax
+            outl %eax,%dx
+         end ['EAX','EDX'];
+      end;
+
+    function inportb(port : word) : byte;
+
+      begin
+         asm
+            movw port,%dx
+            inb %dx,%al
+            movb %al,__RESULT
+         end ['EAX','EDX'];
+      end;
+
+    function inportw(port : word) : word;
+
+      begin
+         asm
+            movw port,%dx
+            inw %dx,%ax
+            movw %ax,__RESULT
+         end ['EAX','EDX'];
+      end;
+
+    function inportl(port : word) : longint;
+
+      begin
+         asm
+            movw port,%dx
+            inl %dx,%eax
+            movl %eax,__RESULT
+         end ['EAX','EDX'];
+      end;
+
+    function get_cs : word;
+
+      begin
+         asm
+            movw %cs,%ax
+            movw %ax,__RESULT;
+         end;
+      end;
+
+
+    function get_ss : word;
+
+      begin
+         asm
+            movw %ss,%ax
+            movw %ax,__RESULT;
+         end;
+      end;
+
+    function get_ds : word;
+
+      begin
+         asm
+            movw %ds,%ax
+            movw %ax,__RESULT;
+         end;
+      end;
+
+    var
+       int31error : word;
+
+    procedure test_int31(flag : longint);[alias : 'test_int31'];
+      begin
+         asm
+            pushl %ebx
+            movl  flag,%ebx
+            testb $1,%bl
+            jz    1f
+            movw  %ax,_INT31ERROR
+            xorl  %eax,%eax
+            jmp   2f
+            1:
+            movl  $1,%eax
+            2:
+            popl  %ebx
+         end;
+      end;
+
+    function set_pm_interrupt(vector : byte;const intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movl intaddr,%eax
+            movl (%eax),%edx
+            movw 4(%eax),%cx
+            movl $0x205,%eax
+            movb vector,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function set_rm_interrupt(vector : byte;const intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movl intaddr,%eax
+            movw (%eax),%dx
+            movw 4(%eax),%cx
+            movl $0x201,%eax
+            movb vector,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function set_pm_exception_handler(e : byte;const intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movl intaddr,%eax
+            movl (%eax),%edx
+            movw 4(%eax),%cx
+            movl $0x212,%eax
+            movb e,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function set_exception_handler(e : byte;const intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movl intaddr,%eax
+            movl (%eax),%edx
+            movw 4(%eax),%cx
+            movl $0x203,%eax
+            movb e,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function get_pm_exception_handler(e : byte;var intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movl $0x210,%eax
+            movb e,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl intaddr,%eax
+            movl %edx,(%eax)
+            movw %cx,4(%eax)
+         end;
+      end;
+
+    function get_exception_handler(e : byte;var intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movl $0x202,%eax
+            movb e,%bl
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl intaddr,%eax
+            movl %edx,(%eax)
+            movw %cx,4(%eax)
+         end;
+      end;
+
+    function get_pm_interrupt(vector : byte;var intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movb vector,%bl
+            movl $0x204,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl intaddr,%eax
+            movl %edx,(%eax)
+            movw %cx,4(%eax)
+         end;
+      end;
+
+    function get_rm_interrupt(vector : byte;var intaddr : tseginfo) : boolean;
+
+      begin
+         asm
+            movb vector,%bl
+            movl $0x200,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl intaddr,%eax
+            movzwl %dx,%edx
+            movl %edx,(%eax)
+            movw %cx,4(%eax)
+         end;
+      end;
+
+    function free_rm_callback(var intaddr : tseginfo) : boolean;
+      begin
+         asm
+            movl intaddr,%eax
+            movw (%eax),%dx
+            movw 4(%eax),%cx
+            movl $0x304,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    { here we must use ___v2prt0_ds_alias instead of from v2prt0.s
+    because the exception processor sets the ds limit to $fff
+    at hardware exceptions }
+
+    function get_rm_callback(pm_func : pointer;const reg : trealregs;var rmcb : tseginfo) : boolean;
+      begin
+         asm
+            movl  pm_func,%esi
+            movl  reg,%edi
+            pushw %es
+{$ifdef GO32V2}
+            movw  ___v2prt0_ds_alias,%ax
+{$else GO32V2}
+            movw  %ds,%ax
+{$endif GO32V2}
+            movw  %ax,%es
+            pushw %ds
+            movw  %cs,%ax
+            movw  %ax,%ds
+            movl  $0x303,%eax
+            int   $0x31
+            popw  %ds
+            popw  %es
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl  rmcb,%eax
+            movzwl %dx,%edx
+            movl  %edx,(%eax)
+            movw  %cx,4(%eax)
+         end;
+      end;
+
+    function allocate_ldt_descriptors(count : word) : word;
+
+      begin
+         asm
+            movw count,%cx
+            xorl %eax,%eax
+            int $0x31
+            movw %ax,__RESULT
+         end;
+      end;
+
+    function free_ldt_descriptor(d : word) : boolean;
+
+      begin
+         asm
+            movw d,%bx
+            movl $1,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function segment_to_descriptor(seg : word) : word;
+
+      begin
+         asm
+            movw seg,%bx
+            movl $2,%eax
+            int $0x31
+            movw %ax,__RESULT
+         end;
+      end;
+
+    function get_next_selector_increment_value : word;
+
+      begin
+         asm
+            movl $3,%eax
+            int $0x31
+            movw %ax,__RESULT
+         end;
+      end;
+
+    function get_segment_base_address(d : word) : longint;
+
+      begin
+         asm
+            movw d,%bx
+            movl $6,%eax
+            int $0x31
+            xorl %eax,%eax
+            movw %dx,%ax
+            shll $16,%ecx
+            orl %ecx,%eax
+            movl %eax,__RESULT
+         end;
+      end;
+
+    function get_page_size:longint;
+      begin
+        asm
+           movl $0x604,%eax
+           int $0x31
+           shll $16,%ebx
+           movw %cx,%bx
+           movl %ebx,__RESULT
+        end;
+      end;
+
+    function request_linear_region(linearaddr, size : longint;
+                                   var blockhandle : longint) : boolean;
+      var
+         pageofs : longint;
+
+      begin
+         pageofs:=linearaddr and $3ff;
+         linearaddr:=linearaddr-pageofs;
+         size:=size+pageofs;
+         asm
+            movl $0x504,%eax
+            movl linearaddr,%ebx
+            movl size,%ecx
+            movl $1,%edx
+            xorl %esi,%esi
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+            movl blockhandle,%eax
+            movl %esi,(%eax)
+            movl %ebx,pageofs
+         end;
+         if pageofs<>linearaddr then
+           request_linear_region:=false;
+      end;
+
+    function allocate_memory_block(size:longint):longint;
+      begin
+        asm
+          movl  $0x501,%eax
+          movl  size,%ecx
+          movl  %ecx,%ebx
+          shrl  $16,%ebx
+          andl  $65535,%ecx
+          int   $0x31
+          jnc   .Lallocate_mem_block_err
+          xorl  %ebx,%ebx
+          xorl  %ecx,%ecx
+       .Lallocate_mem_block_err:
+          shll  $16,%ebx
+          movw  %cx,%bx
+          shll  $16,%esi
+          movw  %di,%si
+          movl  %ebx,__RESULT
+        end;
+     end;
+
+    function free_memory_block(blockhandle : longint) : boolean;
+      begin
+         asm
+            movl blockhandle,%esi
+            movl %esi,%edi
+            shll $16,%esi
+            movl $0x502,%eax
+            int  $0x31
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function lock_linear_region(linearaddr, size : longint) : boolean;
+
+      begin
+          asm
+            movl  $0x600,%eax
+            movl  linearaddr,%ecx
+            movl  %ecx,%ebx
+            shrl  $16,%ebx
+            movl  size,%esi
+            movl  %esi,%edi
+            shrl  $16,%esi
+            int   $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+          end;
+      end;
+
+    function lock_data(var data;size : longint) : boolean;
+
+      var
+         linearaddr : longint;
+
+      begin
+         if get_run_mode <> 4 then
+           exit;
+         linearaddr:=longint(@data)+get_segment_base_address(get_ds);
+         lock_data:=lock_linear_region(linearaddr,size);
+      end;
+
+    function lock_code(functionaddr : pointer;size : longint) : boolean;
+
+      var
+         linearaddr : longint;
+
+      begin
+         if get_run_mode<>rm_dpmi then
+           exit;
+         linearaddr:=longint(functionaddr)+get_segment_base_address(get_cs);
+         lock_code:=lock_linear_region(linearaddr,size);
+      end;
+
+    function unlock_linear_region(linearaddr,size : longint) : boolean;
+
+      begin
+         asm
+            movl  $0x601,%eax
+            movl  linearaddr,%ecx
+            movl  %ecx,%ebx
+            shrl  $16,%ebx
+            movl  size,%esi
+            movl  %esi,%edi
+            shrl  $16,%esi
+            int   $0x31
+            pushf
+            call  test_int31
+            movb  %al,__RESULT
+         end;
+      end;
+
+    function unlock_data(var data;size : longint) : boolean;
+
+      var
+         linearaddr : longint;
+      begin
+         if get_run_mode<>rm_dpmi then
+           exit;
+         linearaddr:=longint(@data)+get_segment_base_address(get_ds);
+         unlock_data:=unlock_linear_region(linearaddr,size);
+      end;
+
+    function unlock_code(functionaddr : pointer;size : longint) : boolean;
+
+      var
+         linearaddr : longint;
+      begin
+         if get_run_mode <>rm_dpmi then
+           exit;
+         linearaddr:=longint(functionaddr)+get_segment_base_address(get_cs);
+         unlock_code:=unlock_linear_region(linearaddr,size);
+      end;
+
+    function set_segment_base_address(d : word;s : longint) : boolean;
+
+      begin
+         asm
+            movw d,%bx
+            leal s,%eax
+            movw (%eax),%dx
+            movw 2(%eax),%cx
+            movl $7,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function set_segment_limit(d : word;s : longint) : boolean;
+
+      begin
+         asm
+            movw d,%bx
+            leal s,%eax
+            movw (%eax),%dx
+            movw 2(%eax),%cx
+            movl $8,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function get_segment_limit(d : word) : longint;
+
+      begin
+         asm
+            movzwl d,%eax
+            lsl %eax,%eax
+            jz .L_ok
+            xorl %eax,%eax
+         .L_ok:
+            movl %eax,__RESULT
+         end;
+      end;
+
+    function create_code_segment_alias_descriptor(seg : word) : word;
+
+      begin
+         asm
+            movw seg,%bx
+            movl $0xa,%eax
+            int $0x31
+            movw %ax,__RESULT
+         end;
+      end;
+
+    function get_meminfo(var meminfo : tmeminfo) : boolean;
+
+      begin
+         asm
+            movl meminfo,%edi
+            movl $0x500,%eax
+            int $0x31
+            pushf
+            call test_int31
+            movb %al,__RESULT
+         end;
+      end;
+
+    function get_linear_addr(phys_addr : longint;size : longint) : longint;
+
+      begin
+         asm
+            movl phys_addr,%ebx
+            movl %ebx,%ecx
+            shrl $16,%ebx
+            movl size,%esi
+            movl %esi,%edi
+            shrl $16,%esi
+            movl $0x800,%eax
+            int $0x31
+            shll $16,%ebx
+            movw %cx,%bx
+            movl %ebx,__RESULT
+         end;
+      end;
+
+    procedure disable;assembler;
+
+      asm
+         cli
+      end;
+
+    procedure enable;assembler;
+
+      asm
+         sti
+      end;
+
+    function get_run_mode : word;
+
+      begin
+         asm
+            movw _run_mode,%ax
+            movw %ax,__RESULT
+         end ['EAX'];
+      end;
+
+    function map_device_in_memory_block(handle,offset,pagecount,device:longint):boolean;
+      begin
+         asm
+           movl device,%edx
+           movl handle,%esi
+           xorl %ebx,%ebx
+           movl pagecount,%ecx
+           movl $0x0508,%eax
+           int $0x31
+           setnc %al
+           movb %al,__RESULT
+         end;
+      end;
+
+    function get_core_selector : word;
+
+      begin
+         asm
+            movw _core_selector,%ax
+            movw %ax,__RESULT
+         end;
+      end;
+
+{$ifndef V0_6}
+
+    function transfer_buffer : longint;
+
+      begin
+         transfer_buffer := go32_info_block.linear_address_of_transfer_buffer;
+      end;
+
+    function tb_size : longint;
+
+      begin
+         tb_size := go32_info_block.size_of_transfer_buffer;
+      end;
+
+     procedure copytodos(var addr; len : longint);
+
+       begin
+          if len>tb_size then runerror(217);
+{$ifdef GO32V2}
+          seg_move(get_ds,longint(@addr),dosmemselector,transfer_buffer,len);
+{$else GO32V2}
+          move(addr,pointer(transfer_buffer)^,len);
+{$endif GO32V2}
+       end;
+
+     procedure copyfromdos(var addr; len : longint);
+
+       begin
+          if len > tb_size then runerror(217);
+{$ifdef GO32V2}
+          seg_move(dosmemselector,transfer_buffer,get_ds,longint(@addr),len);
+{$else GO32V2}
+          move(pointer(transfer_buffer)^,addr,len);
+{$endif GO32V2}
+       end;
+
+{$endif not V0_6}
+
+begin
+{$ifndef go32v2}
+   if not (get_run_mode=rm_dpmi) then
+     begin
+        dosmemget:=@raw_dosmemget;
+        dosmemput:=@raw_dosmemput;
+        dosmemmove:=@raw_dosmemmove;
+        dosmemfillchar:=@raw_dosmemfillchar;
+        dosmemfillword:=@raw_dosmemfillword;
+     end
+   else
+{$endif}
+     begin
+       dosmemselector:=get_core_selector;
+     end;
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:41  root
+  Initial revision
+
+  Revision 1.8  1998/03/24 15:54:14  peter
+    - raw_ functions are not necessary for go32v2, $ifdef'd them
+
+  Revision 1.7  1998/03/24 09:33:59  peter
+    + new trealregs from the mailinglist
+    + 2 new functions get_page_size, map_device_in_mem_block
+
+  Revision 1.6  1998/02/01 09:32:21  florian
+    * some clean up
+
+  Revision 1.5  1998/01/26 11:56:27  michael
+  + Added log at the end
+
+  revision 1.4
+  date: 1997/12/12 13:14:37;  author: pierre;  state: Exp;  lines: +2 -1
+     + added handling of swap_vectors if under exceptions
+       i.e. swapvector is not dummy under go32v2
+     * bug in output, exceptions where not allways reset correctly
+       now the code in dpmiexcp is called from v2prt0.as exit routine
+     * in crt.pp corrected init_delay calibration loop
+       and added it for go32v2 also (was disabled before due to crashes !!)
+       the previous code did a wrong assumption on the time need to call
+       get_ticks compared to an internal loop without call
+  ----------------------------
+  revision 1.3
+  date: 1997/12/11 11:50:37;  author: pierre;  state: Exp;  lines: +2 -2
+    *  bug in get_linear_addr corrected
+       thanks to Raul who found this bug.
+  ----------------------------
+  revision 1.2
+  date: 1997/12/01 12:15:46;  author: michael;  state: Exp;  lines: +10 -3
+  + added copyright reference in header.
+  ----------------------------
+  revision 1.1
+  date: 1997/11/27 08:33:50;  author: michael;  state: Exp;
+  Initial revision
+  ----------------------------
+  revision 1.1.1.1
+  date: 1997/11/27 08:33:50;  author: michael;  state: Exp;  lines: +0 -0
+  FPC RTL CVS start
+  =============================================================================
+
+  History:
+       6th november 1996:
+         + dosmem* implemented
+}

rtl/dos/go32v1/makefile

@@ -0,0 +1,255 @@
+# Makefile for the DOS Go32v1 Run-time library.
+# we need the stupid copies and del because the old FPK Pascal doesn't handle
+# ppc386 ..\crt correct..
+#
+#####################################################################
+# Start of configurable section.
+# Please note that all these must be set in the main makefile, and
+# should be set there.
+# Don't remove the indef statements. They serve to avoid conflicts
+# with the main makefile.
+#####################################################################
+
+# set the directory where to install the units.
+ifndef UNITINSTALLDIR
+UNITINSTALLDIR=c:\lib\ppc
+endif
+
+# set the directory where to install libraries
+ifndef LIBINSTALLDIR
+LIBINSTALLDIR=c:\lib
+endif
+
+# What is the Operating System
+ifndef OS_SRC
+OS_SRC=GO32V1
+endif
+
+# What is the target operating system ?
+ifndef OS_TARGET
+OS_TARGET=GO32V1
+endif
+
+# What compiler to use ?
+# I think ppc386 is better (it's mostly in path) (FK)
+ifndef PP
+PP=ppc386
+endif
+
+# What options to pass to the compiler ?
+# You may want to specify a config file or error definitions file here.
+ifndef OPT
+OPT=
+endif
+
+# Where is the ppumove program ?
+ifndef PPUMOVE
+PPUMOVE=ppumove
+endif
+
+#####################################################################
+# End of configurable section.
+# Do not edit after this line.
+#####################################################################
+
+# Where are the include files
+INC=../../inc
+
+ifndef CPU
+CPU=i386
+endif
+
+PROCINC=../../$(CPU)
+
+# Where are the .ppi files.
+PPI=../ppi
+
+ifeq ($(OS_TARGET),$(OS_SRC))
+CROSSCOMPILE=NO
+else
+CROSSCOMPILE=YES
+endif
+
+# To copy pograms
+ifndef COPY
+COPY=cp -p
+endif
+
+# To delete programs
+ifndef DEL
+ifeq ($(DOS),YES)
+DEL=del
+else
+DEL=rm
+endif
+endif
+
+# To install programs
+ifndef INSTALL
+ifeq ($(DOS),YES)
+INSTALL=cp
+else
+INSTALL=install -m 644
+endif
+endif
+
+
+ifndef MKDIR
+ifeq ($(DOS),YES)
+MKDIR=mkdir
+else
+MKDIR=install -m 755 -d
+endif
+endif
+
+# Check for crosscompile
+ifeq ($(CROSSCOMPILE),YES)
+OPT:=$(OPT) -dCROSSCOMPILE -T$(OS_TARGET)
+endif
+
+# check config file
+ifdef CFGFILE
+OPT:=$(OPT) @$(CFGFILE)
+endif
+
+# to be sure to be able to compile with an older
+# compiler version
+OPT:=$(OPT) -dFPC
+
+# diff program
+ifndef REFPATH
+REFPATH=/usr/local/fpk/work/new/rtl
+endif
+ifndef DIFF
+DIFF=diff
+endif
+ifndef DIFFOPTS
+DIFFOPTS=-b -c
+endif
+
+# os independent depends
+SYSTEMDEPS=$(INC)/system.inc $(INC)/systemh.inc $(INC)/mathh.inc $(INC)/real2str.inc \
+	$(INC)/heaph.inc $(INC)/innr.inc $(INC)/sstrings.inc $(INC)/file.inc \
+	$(INC)/text.inc $(INC)/typefile.inc $(INC)/version.inc $(INC)/filerec.inc \
+	$(INC)/textrec.inc $(INC)/objpas.inc $(INC)/objpash.inc \
+	$(PROCINC)/math.inc $(PROCINC)/set.inc $(PROCINC)/heap.inc $(PROCINC)/$(CPU).inc
+
+PPUEXT=.pp1
+PPLEXT=.ppl
+# At this moment only static libs under go32v2. When shared libs are made then
+# we should ask what kind of lib user wants, and then set the correct
+# extension... (see linux makefile for example)
+LIBEXT=.a1
+OEXT=.o1
+
+.PHONY: all clean install diffs diffclean
+
+all : system$(PPUEXT) prt0$(OEXT) crt$(PPUEXT) go32$(PPUEXT) strings$(PPUEXT) \
+	dos$(PPUEXT) printer$(PPUEXT) objects$(PPUEXT) \
+	mmx$(PPUEXT) cpu$(PPUEXT) \
+	mouse$(PPUEXT) fmouse$(PPUEXT) getopts$(PPUEXT) graph$(PPUEXT)
+
+printer$(PPUEXT) : ../printer.pp system$(PPUEXT)
+	$(COPY) ../printer.pp .
+	$(PP) $(OPT) printer.pp $(REDIR)
+	$(DEL) printer.pp
+
+getopts$(PPUEXT) : $(PROCINC)/getopts.pp system$(PPUEXT)
+	$(COPY) $(PROCINC)/getopts.pp .
+	$(PP) $(OPT) getopts.pp $(REDIR)
+	$(DEL) getopts.pp
+
+graph$(PPUEXT) : ../graph.pp go32$(PPUEXT) system$(PPUEXT) mmx$(PPUEXT) \
+	$(PPI)/arc.ppi $(PPI)/colors.ppi $(PPI)/dpmi2raw.ppi $(PPI)/ellipse.ppi \
+	$(PPI)/fill.ppi $(PPI)/font.ppi $(PPI)/global.ppi $(PPI)/ibm.ppi \
+	$(PPI)/image.ppi $(PPI)/line.ppi $(PPI)/modes.ppi $(PPI)/move.ppi \
+	$(PPI)/palette.ppi $(PPI)/pixel.ppi $(PPI)/stdcolor.ppi $(PPI)/text.ppi \
+	$(PPI)/triangle.ppi $(PPI)/vesadeb.ppi
+	$(COPY) ../graph.pp $(PPI)/*.ppi .
+	$(PP) $(OPT) graph $(REDIR)
+	$(DEL) graph.pp *.ppi
+
+mmx$(PPUEXT) : $(PROCINC)/mmx.pp cpu$(PPUEXT) system$(PPUEXT)
+	$(COPY) $(PROCINC)/mmx.pp .
+	$(PP) $(OPT) mmx.pp $(REDIR)
+	$(DEL) mmx.pp
+
+cpu$(PPUEXT) : ../../i386/cpu.pp system$(PPUEXT)
+	$(COPY) ../../i386/cpu.pp .
+	$(PP) $(OPT) cpu $(REDIR)
+	$(DEL) cpu.pp
+
+strings$(PPUEXT) : $(PROCINC)/strings.pp system$(PPUEXT)
+	$(COPY) $(PROCINC)/strings.pp .
+	$(PP) $(OPT) strings.pp $(REDIR)
+	$(DEL) strings.pp
+
+dos$(PPUEXT) : ../dos.pp $(INC)/filerec.inc $(INC)/textrec.inc \
+	go32$(PPUEXT) system$(PPUEXT) strings$(PPUEXT)
+	$(COPY) ../dos.pp $(INC)/filerec.inc $(INC)/textrec.inc .
+	$(PP) $(OPT) dos $(REDIR)
+	$(DEL) dos.pp filerec.inc textrec.inc
+
+system$(PPUEXT) : system.pp $(SYSTEMDEPS)
+	$(COPY) $(INC)/*.inc $(PROCINC)/*.inc .
+	$(PP) $(OPT) -Us -Sg system $(REDIR)
+	$(DEL) systemh.inc system.inc real2str.inc version.inc $(CPU).inc sstrings.inc
+	$(DEL) mathh.inc math.inc set.inc innr.inc heap.inc heaph.inc objpash.inc
+	$(DEL) filerec.inc textrec.inc file.inc typefile.inc text.inc objpas.inc
+
+prt0$(OEXT) : prt0.as
+	as -D -o prt0$(OEXT) prt0.as
+
+crt$(PPUEXT) : ../crt.pp $(INC)/textrec.inc go32$(PPUEXT) system$(PPUEXT)
+	$(COPY) ../crt.pp $(INC)/textrec.inc .
+	$(PP) $(OPT) crt $(REDIR)
+	$(DEL) crt.pp textrec.inc
+
+go32$(PPUEXT) : ../go32.pp system$(PPUEXT)
+	$(COPY) ../go32.pp .
+	$(PP) $(OPT) go32.pp $(REDIR)
+	$(DEL) go32.pp
+
+objects$(PPUEXT) : ../objects.pp system$(PPUEXT)
+	$(COPY) ../objects.pp .
+	$(PP) $(OPT) objects.pp $(REDIR)
+	$(DEL) objects.pp
+
+mouse$(PPUEXT) : ../mouse.pp system$(PPUEXT)
+	$(COPY) ../mouse.pp .
+	$(PP) $(OPT) mouse.pp $(REDIR)
+	$(DEL) mouse.pp
+
+fmouse$(PPUEXT) : ../fmouse.pp system$(PPUEXT)
+	$(COPY) ../fmouse.pp .
+	$(PP) $(OPT) fmouse.pp $(REDIR)
+	$(DEL) fmouse.pp
+
+clean:
+	-$(DEL) *$(OEXT)
+	-$(DEL) *$(PPUEXT)
+	-$(DEL) *.dif
+	-$(DEL) log
+	-$(DEL) *$(ASMEXT)
+
+diffclean:
+	-$(DEL) *.dif
+
+install: all
+	-$(MKDIR) $(LIBINSTALLDIR)/dosunits
+	$(INSTALL) *$(OEXT) $(LIBINSTALLDIR)/dosunits
+	$(INSTALL) *$(PPUEXT) $(LIBINSTALLDIR)/dosunits
+
+%.dif : %.pp
+	-$(DIFF) $(DIFFOPTS) $*.pp $(REFPATH)/dos/go32v1/$*.pp > $*.dif
+
+%.dif : %.inc
+	-$(DIFF) $(DIFFOPTS) $*.inc $(REFPATH)/dos/go32v1/$*.inc > $*.dif
+
+%.dif : %.as
+	-$(DIFF) $(DIFFOPTS) $*.as $(REFPATH)/dos/go32v1/$*.as > $*.dif
+
+makefile.dif : makefile
+	-$(DIFF) $(DIFFOPTS) makefile $(REFPATH)/dos/go32v1/makefile > makefile.dif
+
+diffs: system.dif os.dif makefile.dif prt0.dif

rtl/dos/go32v1/os.inc

@@ -0,0 +1,45 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+{$define dos}
+{$undef go32v2}
+{$undef os2}
+{$undef linux}
+{$undef win32}
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:41  root
+  Initial revision
+
+  Revision 1.3  1998/01/26 11:57:08  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/dos/go32v1/os.inc
+  description:
+  ----------------------------
+  revision 1.2
+  date: 1997/12/01 12:24:05;  author: michael;  state: Exp;  lines: +13 -0
+  + added copyright reference in header.
+  ----------------------------
+  revision 1.1
+  date: 1997/11/27 08:33:53;  author: michael;  state: Exp;
+  Initial revision
+  ----------------------------
+  revision 1.1.1.1
+  date: 1997/11/27 08:33:53;  author: michael;  state: Exp;  lines: +0 -0
+  FPC RTL CVS start
+  =============================================================================
+}

rtl/dos/go32v1/prt0.as

@@ -0,0 +1,183 @@
+#
+#    $Id$
+#    This file is part of the Free Pascal run time library.
+#    Copyright (c) 1993,97 by the Free Pascal development team.
+#
+#    See the file COPYING.FPC, included in this distribution,
+#    for details about the copyright.
+#
+#    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.
+#
+# **********************************************************************
+#///*
+#//**	Called as start(argc, argv, envp)
+#//*/
+#///*	gs:edx points to prog_info structure.  All other registers are OBSOLETE
+#//**	but included for backwards compatibility
+#//*/
+
+	.text
+	.globl	_start
+_start:
+	.globl	start
+start:
+# the first instruction must be movl %eax,
+# because that is the way GO32V2 makes the difference between V1 and V2 coff format
+	movl	%eax,__hard_master
+	movl	%esi,___pid
+	movl	%edi,___transfer_buffer
+	movl	%ebx,_ScreenPrimary
+	movl	%ebp,_ScreenSecondary
+	cmpl	$0, %edx
+	je	Lcopy_none
+	movw	%gs,%cx
+	movw	%ds,%ax
+	cmpw	%cx,%ax
+	je	Lcopy_none
+#   /* set the right size */
+	movl  $40,U_SYSTEM_GO32_INFO_BLOCK
+
+	movl	%gs:(%edx), %ecx
+	cmpl	U_SYSTEM_GO32_INFO_BLOCK, %ecx
+	jbe	Lcopy_less
+	movl	U_SYSTEM_GO32_INFO_BLOCK, %ecx
+Lcopy_less:
+	movl	$U_SYSTEM_GO32_INFO_BLOCK, %edi
+	addl	$3, %ecx
+	andl	$0xfffffffc, %ecx
+	movl	%ecx, (%edi)
+	addl	$4, %edi
+	addl	$4, %edx
+	subl	$4, %ecx
+Lcopy_more:
+	movl	%gs:(%edx), %eax
+	movl	%eax, (%edi)
+	addl	$4, %edx
+	addl	$4, %edi
+	subl	$4, %ecx
+	jnz	Lcopy_more
+
+	movl	U_SYSTEM_GO32_INFO_BLOCK+4, %eax
+	movl	%eax, _ScreenPrimary
+	movl	U_SYSTEM_GO32_INFO_BLOCK+8, %eax
+	movl	%eax, _ScreenSecondary
+        movl	U_SYSTEM_GO32_INFO_BLOCK+12, %eax
+	movl	%eax, ___transfer_buffer
+	movl	U_SYSTEM_GO32_INFO_BLOCK+20, %eax
+	movl	%eax, ___pid
+	movl	U_SYSTEM_GO32_INFO_BLOCK+24, %eax
+	movl	%eax, __hard_master
+
+	jmp	Lcopy_done
+
+Lcopy_none:
+	movl	%ebx,U_SYSTEM_GO32_INFO_BLOCK+4
+	movl	%ebp,U_SYSTEM_GO32_INFO_BLOCK+8
+	movl	%edi,U_SYSTEM_GO32_INFO_BLOCK+12
+	movl	$4096,U_SYSTEM_GO32_INFO_BLOCK+16
+	movl	%esi,U_SYSTEM_GO32_INFO_BLOCK+20
+	movl	%eax,U_SYSTEM_GO32_INFO_BLOCK+24
+	movl	$28, U_SYSTEM_GO32_INFO_BLOCK
+Lcopy_done:
+
+        movw    U_SYSTEM_GO32_INFO_BLOCK+36,%ax
+        movw    %ax,_run_mode
+#/* I need a value for the stack bottom,            */
+#/* but I don't know how to get it from go32        */
+#/* I suppose the stack is 4Ko long, is this true ? */
+        movl    %esp,%eax
+        subl    $0x4000,%eax
+        movl    %eax,__stkbottom
+
+        movw    U_SYSTEM_GO32_INFO_BLOCK+26,%ax
+        movw    %ax,_core_selector
+   	movl    U_SYSTEM_GO32_INFO_BLOCK+28,%eax
+   	movl  %eax,U_SYSTEM_STUB_INFO
+	xorl	%esi,%esi
+	xorl	%edi,%edi
+	xorl	%ebp,%ebp
+	xorl	%ebx,%ebx
+
+	movl	%esp,%ebx
+        movl    $0x0,%ebp
+	movl	%esp,%ebx
+	movl	8(%ebx),%eax
+	movl	%eax,_environ
+	movl	4(%ebx),%eax
+	movl	%eax,_args
+	movl	(%ebx),%eax
+	movl	%eax,_argc
+
+	call	PASCALMAIN
+
+
+exit_again:
+	movl	$0x4c00,%eax
+	int	$0x21
+	jmp	exit_again
+
+	ret
+
+	.data
+        .globl _argc
+_argc:
+	.long   0
+	.globl  _args
+_args:
+	.long	0
+	.globl	_run_mode
+_run_mode:
+	.word	0
+	.globl	_core_selector
+_core_selector:
+	.word	0
+	.globl	_environ
+_environ:
+	.long	0
+
+	.globl	___pid
+___pid:
+	.long	42
+
+	.globl	___transfer_buffer
+___transfer_buffer:
+	.long	0
+
+	.globl	_ScreenPrimary
+_ScreenPrimary:
+	.long	0
+
+	.globl	_ScreenSecondary
+_ScreenSecondary:
+	.long	0
+
+	.globl	__hard_master
+	.globl	__hard_slave
+	.globl	__core_select
+__hard_master:
+	.byte	0
+__hard_slave:
+	.byte	0
+__core_select:
+	.short	0
+        .globl  __stkbottom
+__stkbottom:
+        .long   0
+#  .globl U_SYSTEM_GO32_INFO_BLOCK
+# U_SYSTEM_GO32_INFO_BLOCK:
+#  .long  __go32_end - U_SYSTEM_GO32_INFO_BLOCK #//* size */
+#  .long  0 #//* offs 4 linear_address_of_primary_screen; */
+#  .long  0 #//* offs 8 linear_address_of_secondary_screen; */
+#  .long  0 #//* offs 12 linear_address_of_transfer_buffer; */
+#  .long  0 #//* offs 16 size_of_transfer_buffer;  >= 4k */
+#  .long  0 #//* offs 20 pid; */
+#  .byte  0 #//* offs 24 u_char master_interrupt_controller_base; */
+#  .byte  0 #//* offs 25 u_char slave_interrupt_controller_base; */
+#  .word  0 #//* offs 26 u_short selector_for_linear_memory; */
+#  .long  0 #//* offs 28 u_long linear_address_of_stub_info_structure; */
+#  .long  0 #//* offs 32 u_long linear_address_of_original_psp; */
+#  .word  0 #//* offs 36 u_short run_mode; */
+#  .word  0 #//* offs 38 u_short run_mode_info; */
+#__go32_end:

rtl/dos/go32v1/system.pp

@@ -0,0 +1,680 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by Florian Klaempfl,
+    member of the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+
+{ system unit for go32v1 }
+{$define DOS}
+unit system;
+
+{$I os.inc}
+
+  interface
+
+    { die betriebssystemunabhangigen Deklarationen einfuegen: }
+
+    {$I systemh.inc}
+
+    {$I heaph.inc}
+
+const
+  UnusedHandle=$ffff;
+  StdInputHandle=0;
+  StdOutputHandle=1;
+  StdErrorHandle=2;
+
+type
+{$PACKRECORDS 1}
+       t_stub_info   = record
+       magic         : array[0..15] of char;
+       size          : longint;
+       minstack      : longint;
+       memory_handle : longint;
+       initial_size  : longint;
+       minkeep       : word;
+       ds_selector   : word;
+       ds_segment    : word;
+       psp_selector  : word;
+       cs_selector   : word;
+       env_size      : word;
+       basename      : array[0..7] of char;
+       argv0         : array [0..15] of char;
+       dpmi_server   : array [0..15] of char;
+       end;
+       p_stub_info   = ^t_stub_info;
+
+       t_go32_info_block = record
+       size_of_this_structure_in_bytes : longint; {offset 0}
+       linear_address_of_primary_screen : longint; {offset 4}
+       linear_address_of_secondary_screen : longint; {offset 8}
+       linear_address_of_transfer_buffer : longint; {offset 12}
+       size_of_transfer_buffer : longint; {offset 16}
+       pid : longint; {offset 20}
+       master_interrupt_controller_base : byte; {offset 24}
+       slave_interrupt_controller_base : byte; {offset 25}
+       selector_for_linear_memory : word; {offset 26}
+       linear_address_of_stub_info_structure : longint; {offset 28}
+       linear_address_of_original_psp : longint; {offset 32}
+       run_mode : word; {offset 36}
+       run_mode_info : word; {offset 38}
+       end;
+{$PACKRECORDS NORMAL}
+
+var
+  stub_info       : p_stub_info;
+  go32_info_block : t_go32_info_block;
+
+  implementation
+
+    { include system independent routines }
+
+    {$I system.inc}
+
+{    type
+       plongint = ^longint;}
+
+{$S-}
+    procedure st1(stack_size : longint);[public,alias: 'STACKCHECK'];
+
+      begin
+         { called when trying to get local stack }
+         { if the compiler directive $S is set   }
+         { this function must preserve esi !!!!  }
+         { because esi is set by the calling     }
+         { proc for methods                      }
+         { it must preserve all registers !!     }
+
+         asm
+            pushl %eax
+            pushl %ebx
+            movl stack_size,%ebx
+            movl %esp,%eax
+            subl %ebx,%eax
+{$ifdef SYSTEMDEBUG}
+            movl U_SYSTEM_LOWESTSTACK,%ebx
+            cmpl %eax,%ebx
+            jb   _is_not_lowest
+            movl %eax,U_SYSTEM_LOWESTSTACK
+            _is_not_lowest:
+{$endif SYSTEMDEBUG}
+            movl __stkbottom,%ebx
+            cmpl %eax,%ebx
+            jae  __short_on_stack
+            popl %ebx
+            popl %eax
+            leave
+            ret  $4
+            __short_on_stack:
+            { can be usefull for error recovery !! }
+            popl %ebx
+            popl %eax
+         end['EAX','EBX'];
+         RunError(202);
+         { this needs a local variable }
+         { so the function called itself !! }
+         { Writeln('low in stack ');
+         RunError(202);             }
+      end;
+
+    procedure halt(errnum : byte);
+
+      begin
+         do_exit;
+         flush(stderr);
+         asm
+            movl $0x4c00,%eax
+            movb 8(%ebp),%al
+            int $0x21
+         end;
+      end;
+
+    function paramcount : longint;
+
+      begin
+         asm
+            movl _argc,%eax
+            decl %eax
+            leave
+            ret
+         end ['EAX'];
+      end;
+
+    function paramstr(l : longint) : string;
+
+      function args : pointer;
+
+        begin
+           asm
+              movl _args,%eax
+              leave
+              ret
+           end ['EAX'];
+        end;
+
+      var
+         p : ^pchar;
+
+      begin
+         if (l>=0) and (l<=paramcount) then
+           begin
+              p:=args;
+              paramstr:=strpas(p[l]);
+           end
+         else paramstr:='';
+      end;
+
+    procedure randomize;
+
+      var
+         hl : longint;
+      begin
+         asm
+            movb $0x2c,%ah
+            int $0x21
+            movw %cx,-4(%ebp)
+            movw %dx,-2(%ebp)
+         end;
+         randseed:=hl;
+      end;
+
+{ use standard heap management }
+{ sbrk function of go32v1 }
+  function Sbrk(size : longint) : longint;
+
+    begin
+       asm
+         movl size,%ebx
+         movl $0x4a01,%eax
+         int  $0x21
+         movl %eax,__RESULT
+       end;
+    end;
+
+{$I heap.inc}
+
+
+{****************************************************************************
+                          Low Level File Routines
+ ****************************************************************************}
+
+procedure AllowSlash(p:pchar);
+var
+  i : longint;
+begin
+{ allow slash as backslash }
+  for i:=0 to strlen(p) do
+   if p[i]='/' then p[i]:='\';
+end;
+
+
+procedure do_close(h : longint);
+begin
+   asm
+      movl 8(%ebp),%ebx
+      movb $0x3e,%ah
+      pushl %ebp
+      intl $0x21
+      popl %ebp
+   end;
+end;
+
+
+procedure do_erase(p : pchar);
+begin
+  AllowSlash(p);
+  asm
+     movl 8(%ebp),%edx
+     movb $0x41,%ah
+     pushl %ebp
+     int $0x21
+     popl %ebp
+     jnc .LERASE1
+     movw %ax,U_SYSTEM_INOUTRES;
+  .LERASE1:
+  end;
+end;
+
+
+procedure do_rename(p1,p2 : pchar);
+begin
+  AllowSlash(p1);
+  AllowSlash(p2);
+  asm
+     movl 8(%ebp),%edx
+     movl 12(%ebp),%edi
+     movb $0x56,%ah
+     pushl %ebp
+     int $0x21
+     popl %ebp
+     jnc .LRENAME1
+     movw %ax,U_SYSTEM_INOUTRES;
+  .LRENAME1:
+  end;
+end;
+
+
+function do_write(h,addr,len : longint) : longint;
+begin
+  asm
+     movl 16(%ebp),%ecx
+     movl 12(%ebp),%edx
+     movl 8(%ebp),%ebx
+     movb $0x40,%ah
+     int $0x21
+     jnc .LDOSWRITE1
+     movw %ax,U_SYSTEM_INOUTRES;
+  .LDOSWRITE1:
+     movl %eax,-4(%ebp)
+  end;
+end;
+
+
+function do_read(h,addr,len : longint) : longint;
+begin
+  asm
+     movl 16(%ebp),%ecx
+     movl 12(%ebp),%edx
+     movl 8(%ebp),%ebx
+     movb $0x3f,%ah
+     int $0x21
+     jnc .LDOSREAD1
+     movw %ax,U_SYSTEM_INOUTRES;
+     xorl %eax,%eax
+  .LDOSREAD1:
+     leave
+     ret $12
+  end;
+end;
+
+
+function do_filepos(handle : longint) : longint;
+begin
+  asm
+     movb $0x42,%ah
+     movb $0x1,%al
+     movl 8(%ebp),%ebx
+     xorl %ecx,%ecx
+     xorl %edx,%edx
+     pushl %ebp
+     int $0x21
+     popl %ebp
+     jnc .LDOSFILEPOS1
+     movw %ax,U_SYSTEM_INOUTRES;
+     xorl %eax,%eax
+     jmp .LDOSFILEPOS2
+  .LDOSFILEPOS1:
+     shll $16,%edx
+     movzwl %ax,%eax
+     orl %edx,%eax
+  .LDOSFILEPOS2:
+     leave
+     ret $4
+  end;
+end;
+
+
+procedure do_seek(handle,pos : longint);
+begin
+  asm
+     movl $0x4200,%eax
+     movl 8(%ebp),%ebx
+     movl 12(%ebp),%edx
+     movl %edx,%ecx
+     shrl $16,%ecx
+     pushl %ebp
+     int $0x21
+     popl %ebp
+     jnc .LDOSSEEK1
+     movw %ax,U_SYSTEM_INOUTRES;
+  .LDOSSEEK1:
+     leave
+     ret $8
+  end;
+end;
+
+
+function do_seekend(handle : longint) : longint;
+begin
+  asm
+     movl $0x4202,%eax
+     movl 8(%ebp),%ebx
+     xorl %ecx,%ecx
+     xorl %edx,%edx
+     pushl %ebp
+     int $0x21
+     popl %ebp
+     jnc .Lset_at_end1
+     movw %ax,U_SYSTEM_INOUTRES;
+     xorl %eax,%eax
+     jmp .Lset_at_end2
+  .Lset_at_end1:
+     shll $16,%edx
+     movzwl %ax,%eax
+     orl %edx,%eax
+  .Lset_at_end2:
+     leave
+     ret $4
+  end;
+end;
+
+
+function do_filesize(handle : longint) : longint;
+var
+   aktfilepos : longint;
+begin
+   aktfilepos:=do_filepos(handle);
+   do_filesize:=do_seekend(handle);
+   do_seek(handle,aktfilepos);
+end;
+
+
+procedure do_truncate(handle,pos : longint);
+begin
+   asm
+      movl $0x4200,%eax
+      movl 8(%ebp),%ebx
+      movl 12(%ebp),%edx
+      movl %edx,%ecx
+      shrl $16,%ecx
+      pushl %ebp
+      int $0x21
+      popl %ebp
+      jc .LTruncate1
+      movl 8(%ebp),%ebx
+      movl 12(%ebp),%edx
+      movl %ebp,%edx
+      xorl %ecx,%ecx
+      movb $0x40,%ah
+      int $0x21
+      jnc .LTruncate2
+   .LTruncate1:
+      movw %ax,U_SYSTEM_INOUTRES;
+   .LTruncate2:
+      leave
+      ret $8
+   end;
+end;
+
+
+procedure do_open(var f;p:pchar;flags:longint);
+{
+  filerec and textrec have both handle and mode as the first items so
+  they could use the same routine for opening/creating.
+  when (flags and $10)   the file will be append
+  when (flags and $100)  the file will be truncate/rewritten
+  when (flags and $1000) there is no check for close (needed for textfiles)
+}
+var
+   oflags : longint;
+begin
+  AllowSlash(p);
+{ close first if opened }
+  if ((flags and $1000)=0) then
+   begin
+     case filerec(f).mode of
+      fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
+      fmclosed : ;
+     else
+      begin
+        inoutres:=102; {not assigned}
+        exit;
+      end;
+     end;
+   end;
+{ reset file handle }
+  filerec(f).handle:=UnusedHandle;
+  oflags:=$8404;
+{ convert filemode to filerec modes }
+  case (flags and 3) of
+   0 : begin
+         filerec(f).mode:=fminput;
+         oflags:=$8001;
+       end;
+   1 : filerec(f).mode:=fmoutput;
+   2 : filerec(f).mode:=fminout;
+  end;
+  if (flags and $100)<>0 then
+   begin
+     filerec(f).mode:=fmoutput;
+     oflags:=$8302;
+   end
+  else
+   if (flags and $10)<>0 then
+    begin
+      filerec(f).mode:=fmoutput;
+      oflags:=$8404;
+    end;
+{ empty name is special }
+  if p[0]=#0 then
+   begin
+     case filerec(f).mode of
+       fminput : filerec(f).handle:=StdInputHandle;
+      fmappend,
+      fmoutput : begin
+                   filerec(f).handle:=StdOutputHandle;
+                   filerec(f).mode:=fmoutput; {fool fmappend}
+                 end;
+     end;
+     exit;
+   end;
+   asm
+      movl $0xff02,%ax
+      movl -4(%ebp),%ecx
+      movl 12(%ebp),%ebx
+      int $0x21
+      jnc .LOPEN1
+      movw %ax,U_SYSTEM_INOUTRES;
+      movw $0xffff,%ax
+   .LOPEN1:
+      movl 8(%ebp),%edx
+      movw %ax,(%edx)
+   end;
+  if (flags and $10)<>0 then
+   do_seekend(filerec(f).handle);
+end;
+
+{*****************************************************************************
+                           UnTyped File Handling
+*****************************************************************************}
+
+{$i file.inc}
+
+{*****************************************************************************
+                           Typed File Handling
+*****************************************************************************}
+
+{$i typefile.inc}
+
+{*****************************************************************************
+                           Text File Handling
+*****************************************************************************}
+
+{$DEFINE EOF_CTRLZ}
+
+{$i text.inc}
+
+{*****************************************************************************
+                           Directory Handling
+*****************************************************************************}
+
+procedure DosDir(func:byte;const s:string);
+var
+  buffer : array[0..255] of char;
+begin
+  move(s[1],buffer,length(s));
+  buffer[length(s)]:=#0;
+  AllowSlash(pchar(@buffer));
+  asm
+    leal buffer,%edx
+    movb 8(%ebp),%ah
+    int  $0x21
+    jnc  .LDOS_DIRS1
+    movw %ax,U_SYSTEM_INOUTRES;
+  .LDOS_DIRS1:
+  end;
+end;
+
+
+procedure mkdir(const s : string);
+begin
+  DosDir($39,s);
+end;
+
+
+procedure rmdir(const s : string);
+begin
+  DosDir($3a,s);
+end;
+
+
+procedure chdir(const s : string);
+begin
+  DosDir($3b,s);
+end;
+
+{ thanks to Michael Van Canneyt <[email protected]>, }
+{ who writes this code                                               }
+{ her is a problem if the getdir is called with a pathstr var in dos.pp }
+procedure getdir(drivenr : byte;var dir : string);
+var
+  temp : array[0..255] of char;
+  sof  : pchar;
+  i    : byte;
+begin
+  sof:=pchar(@dir[4]);
+  { dir[1..3] will contain '[drivenr]:\', but is not }
+  { supplied by DOS, so we let dos string start at   }
+  { dir[4]                                           }
+  { Get dir from drivenr : 0=default, 1=A etc... }
+  asm
+    movb drivenr,%dl
+    movl sof,%esi
+    mov  $0x47,%ah
+    int  $0x21
+  end;
+{ Now Dir should be filled with directory in ASCIIZ, }
+{ starting from dir[4]                               }
+  dir[0]:=#3;
+  dir[2]:=':';
+  dir[3]:='\';
+  i:=4;
+{ conversation to Pascal string }
+  while (dir[i]<>#0) do
+   begin
+   { convert path name to DOS }
+     if dir[i]='/' then
+      dir[i]:='\';
+     dir[0]:=chr(i);
+     inc(i);
+   end;
+{ upcase the string (FPKPascal function) }
+  dir:=upcase(dir);
+  if drivenr<>0 then   { Drive was supplied. We know it }
+   dir[1]:=chr(65+drivenr-1)
+  else
+   begin
+   { We need to get the current drive from DOS function 19H  }
+   { because the drive was the default, which can be unknown }
+     asm
+       movb $0x19,%ah
+       int $0x21
+       addb $65,%al
+       movb %al,i
+     end;
+     dir[1]:=chr(i);
+   end;
+end;
+
+
+{*****************************************************************************
+                         SystemUnit Initialization
+*****************************************************************************}
+
+procedure OpenStdIO(var f:text;mode:word;hdl:longint);
+begin
+  Assign(f,'');
+  TextRec(f).Handle:=hdl;
+  TextRec(f).Mode:=mode;
+  TextRec(f).InOutFunc:=@FileInOutFunc;
+  TextRec(f).FlushFunc:=@FileInOutFunc;
+  TextRec(f).Closefunc:=@fileclosefunc;
+end;
+
+     
+Begin
+{ Initialize ExitProc }
+  ExitProc:=Nil;
+{ to test stack depth }
+  loweststack:=maxlongint;
+{ Setup heap }
+  InitHeap;
+{ Setup stdin, stdout and stderr }
+  OpenStdIO(Input,fmInput,StdInputHandle);
+  OpenStdIO(Output,fmOutput,StdOutputHandle);
+  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
+{ Reset IO Error }  
+  InOutRes:=0;
+End.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:41  root
+  Initial revision
+
+  Revision 1.9  1998/02/14 01:41:35  peter
+    * fixed unusedhandle bug which was -1
+
+  Revision 1.8  1998/01/26 11:57:03  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/dos/go32v1/system.pp
+  description:
+  ----------------------------
+  revision 1.7
+  date: 1998/01/25 21:53:22;  author: peter;  state: Exp;  lines: +12 -8
+    + Universal Handles support for StdIn/StdOut/StdErr
+    * Updated layout of sysamiga.pas
+  ----------------------------
+  revision 1.6
+  date: 1998/01/16 23:10:50;  author: florian;  state: Exp;  lines: +2 -2
+    + some tobject stuff
+  ----------------------------
+  revision 1.5
+  date: 1998/01/11 02:47:31;  author: michael;  state: Exp;  lines: +384 -507
+  * Changed files to use the new filestructure in /inc directory.
+    (By Peter Vreman)
+  ----------------------------
+  revision 1.4
+  date: 1998/01/07 00:05:04;  author: michael;  state: Exp;  lines: +189 -184
+  + Final adjustments  for a uniform file handling interface.
+     (From Peter Vreman)
+  ----------------------------
+  revision 1.3
+  date: 1998/01/05 16:51:04;  author: michael;  state: Exp;  lines: +18 -46
+  + Moved init of heap to heap.inc: INITheap() (From Peter Vreman)
+  ----------------------------
+  revision 1.2
+  date: 1997/12/01 12:24:06;  author: michael;  state: Exp;  lines: +12 -3
+  + added copyright reference in header.
+  ----------------------------
+  revision 1.1
+  date: 1997/11/27 08:33:53;  author: michael;  state: Exp;
+  Initial revision
+  ----------------------------
+  revision 1.1.1.1
+  date: 1997/11/27 08:33:53;  author: michael;  state: Exp;  lines: +0 -0
+  FPC RTL CVS start
+  =============================================================================
+}

rtl/dos/go32v2/dpmiexcp.pp

@@ -0,0 +1,1020 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by Pierre Muller,
+    member of the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+{ Translated to FPK pascal by Pierre Muller,
+without changing the exceptn.s file }
+Unit DPMIEXCP;
+
+{$I os.inc}
+
+{ Real mode control-C check removed
+because I got problems with the RMCB
+can be used by setting this conditionnal }
+{$define UseRMcbrk}
+
+interface
+
+uses go32{,sysutils};
+
+{$S- no stack check !!! }
+{$packrecords 2 }
+type   tjmprec = record
+          eax,ebx,ecx,edx,esi,edi,ebp,esp,eip,flags : longint;
+          cs,ds,es,fs,gs,ss : word;
+          { we should also save the FPU state, if we use this for excpections }
+          { and the compiler supports FPU register variables }
+       end;
+    type pjmprec = ^tjmprec;
+
+type texception_state = record
+  __eax, __ebx, __ecx, __edx, __esi : longint;
+  __edi, __ebp, __esp, __eip, __eflags : longint;
+  __cs, __ds, __es, __fs, __gs, __ss : word;
+  __sigmask : longint; {  for POSIX signals only  }
+  __signum : longint; {  for expansion  }
+  __exception_ptr : longint; {  pointer to previous exception  }
+  __fpu_state : array [0..108-1] of byte; {  for future use  }
+  end;
+    pexception_state = ^texception_state;
+
+{ /* Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details */ }
+{#define __djgpp_exception_state (*__djgpp_exception_state_ptr) }
+const SIGABRT	= 288;
+const SIGFPE	= 289;
+const SIGILL	= 290;
+const SIGSEGV	= 291;
+const SIGTERM	= 292;
+const SIGINT   = 295;
+
+{const SIG_DFL  = 0;}
+function SIG_DFL( x: longint) : longint;
+function SIG_ERR( x: longint) : longint;
+function SIG_IGN( x: longint) : longint;
+{const SIG_ERR	= -1;
+const SIG_IGN	= -1;}
+
+{ __DJ_pid_t
+#undef __DJ_pid_t
+const __DJ_pid_t
+
+typedef int sig_atomic_t;
+
+int	raise(int _sig);
+void	(*signal(int _sig, void (*_func)(int)))(int); }
+  
+{ #ifndef __STRICT_ANSI__
+
+const SA_NOCLDSTOP	1
+
+const SIGALRM	293
+const SIGHUP	294
+/* SIGINT is ansi */}
+const SIGKILL	= 296;
+const SIGPIPE	= 297;
+const SIGQUIT	= 298;
+const SIGUSR1	= 299;
+const SIGUSR2	= 300;
+{
+const SIG_BLOCK	1
+const SIG_SETMASK	2
+const SIG_UNBLOCK	3 }
+
+const SIGNOFP = 301;
+const SIGTRAP = 302;
+const SIGTIMR = 303;	{/* Internal for setitimer (SIGALRM, SIGPROF) */ }
+const SIGPROF = 304;
+const SIGMAX  = 320;
+
+
+
+{ extern unsigned short __djgpp_our_DS;
+extern unsigned short __djgpp_app_DS;	/* Data selector invalidated by HW ints */
+extern unsigned short __djgpp_ds_alias;	/* Data selector always valid */
+extern unsigned short __djgpp_dos_sel;	/* Linear mem selector copy in locked mem */
+extern unsigned short __djgpp_hwint_flags; /* 1 = Disable Ctrl-C; 2 = Count Ctrl-Break (don't kill) */
+extern unsigned __djgpp_cbrk_count;	/* Count of CTRL-BREAK hits */
+extern int __djgpp_exception_inprog;	/* Nested exception count */ }
+
+type SignalHandler = function (v : longint) : longint;
+
+function signal(sig : longint;func : SignalHandler) : SignalHandler;
+
+function _raise(sig : longint) : longint;
+
+procedure djgpp_exception_toggle;
+
+function  djgpp_set_ctrl_c(enable : boolean) : boolean; {	/* On by default */}
+
+procedure djgpp_exception_setup;
+
+function djgpp_exception_state : pexception_state;
+
+function do_faulting_finish_message : integer;
+
+function setjmp(var rec : tjmprec) : longint;
+
+function dpmi_set_coprocessor_emulation(flag : longint) : longint;
+
+procedure longjmp({const}var rec : tjmprec;return_value : longint);
+
+implementation
+
+{$L exceptn.o}
+
+const exceptions_on : boolean = false;
+
+var starttext, endtext : pointer;
+
+function SIG_ERR( x: longint) : longint;
+begin
+   SIG_ERR:=-1;
+end;
+
+function SIG_IGN( x: longint) : longint;
+begin
+   SIG_IGN:=-1;
+end;
+
+function SIG_DFL( x: longint) : longint;
+begin
+   SIG_DFL:=0;
+end;
+
+{ #include <libc/stubs.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <io.h>
+#include <libc/farptrgs.h>
+#include <dpmi.h>
+#include <go32.h>
+#include <signal.h>
+#include <setjmp.h>
+#include <errno.h>
+#include <crt0.h>
+#include <pc.h>
+#include <sys/exceptn.h>
+#include <sys/nearptr.h>		/* For DS base/limit info */
+#include <libc/internal.h> }
+
+const newline = #13#10;
+
+procedure err(x : string);
+begin
+   write(stderr, x);
+   flush(stderr);
+end;
+
+{ extern unsigned end __asm__ ('end'); }
+const cbrk_vect : byte = $1b;
+{	/* May be $06 for PC98 */ }
+
+{ /* These are all defined in exceptn.S and only used here */
+extern int __djgpp_exception_table;
+extern int __djgpp_npx_hdlr;
+extern int __djgpp_kbd_hdlr;
+extern int __djgpp_kbd_hdlr_pc98;
+extern int __djgpp_iret, __djgpp_i24;
+extern void __djgpp_cbrk_hdlr(void);
+extern int __djgpp_hw_lock_start, __djgpp_hw_lock_end;
+extern tseginfo __djgpp_old_kbd; }
+
+procedure itox(v,len : longint);
+  var st : string;
+  begin
+     st:=hexstr(v,len);
+     write(stderr,st);
+     flush(stderr);
+  end;
+
+function except_to_sig(excep : longint) : longint;
+  begin
+     case excep of
+        5,8,9,11,12,13,14 : exit(SIGSEGV);
+        0,4,16            : exit(SIGFPE);
+        1,3               : exit(SIGTRAP);
+        7                 : exit(SIGNOFP);
+        else
+           begin
+              if(excep = $75)	then	{/* HW int to fake exception values hardcoded in exceptn.S */}
+                exit(SIGFPE)
+              else if (excep = $78) then
+                exit(SIGTIMR)
+              else if ((excep = $79) or (excep = $1b)) then
+                exit(SIGINT)
+              else
+                exit(SIGILL);
+           end;
+        end;
+  end;
+
+  function djgpp_exception_state : pexception_state;
+    begin
+       asm
+          movl ___djgpp_exception_state_ptr,%eax
+          movl %eax,__RESULT
+       end;
+    end;
+
+procedure show_call_frame;
+
+  begin
+     err('Call frame traceback EIPs:'+newline);
+     err('  0x'+hexstr(djgpp_exception_state^.__eip, 8)+newline);
+     dump_stack(djgpp_exception_state^.__ebp);
+  end;
+
+const EXCEPTIONCOUNT = 18;
+const exception_names : array[0..EXCEPTIONCOUNT-1] of pchar = (
+  'Division by Zero',
+  'Debug',
+  'NMI',
+  'Breakpoint',
+  'Overflow',
+  'Bounds Check',
+  'Invalid Opcode',
+  'Coprocessor not available',
+  'Double Fault',
+  'Coprocessor overrun',
+  'Invalid TSS',
+  'Segment Not Present',
+  'Stack Fault',
+  'General Protection Fault',
+  'Page fault',
+  ' ',
+  'Coprocessor Error',
+  'Alignment Check');
+
+const has_error : array [0..EXCEPTIONCOUNT-1] of byte =
+   (0,0,0,0,0,0,0,0,1,0,1,1,1,1,1,0,0,1);
+
+const
+    cbrk_hooked : boolean = false;
+
+
+procedure dump_selector(const name : string; sel : word);
+  var base,limit : longint;
+  begin
+     write(stderr, name);
+     err(': sel=');
+     itox(sel, 4);
+  if (sel<>0) then
+    begin
+       base:=get_segment_base_address(sel);
+   
+       {
+         err('  invalid');
+       }
+       { else }
+   
+       err('  base='); itox(base, 8);
+       limit:=get_segment_limit(sel);
+       err('  limit='); itox(limit, 8);
+    end;
+  err(newline);
+  end;
+
+function farpeekb(sel : word;offset : longint) : byte;
+  var b : byte;
+  begin
+     seg_move(sel,offset,get_ds,longint(@b),1);
+     farpeekb:=b;
+  end;
+
+  const old_video_mode : byte = 3;
+
+function do_faulting_finish_message : integer;
+  var en : pchar;
+      signum,i : longint;
+      old_vid : byte;
+  begin
+     do_faulting_finish_message:=0;
+     signum:=djgpp_exception_state^.__signum;
+     {/* check video mode for original here and reset (not if PC98) */ }
+     if ((go32_info_block.linear_address_of_primary_screen <> $a0000) and
+        (farpeekb(dosmemselector, $449) <> old_video_mode)) then
+       begin
+          old_vid:=old_video_mode;
+          asm
+             pusha
+             movzbl old_vid,%eax
+             int $0x10
+             popa
+             nop
+          end;
+       end;
+
+     if (signum >= EXCEPTIONCOUNT) then
+       en:=nil
+     else
+       en:=exception_names[signum];
+     if (signum = $75) then
+       en:='Floating Point exception';
+     if (signum = $1b) then
+       en:='Control-Break Pressed';
+     if (signum = $79) then
+       en:='Control-C Pressed';
+     if (en = nil) then
+       begin
+          err('Exception ');
+          itox(signum, 2);
+          err(' at eip=');
+          itox(djgpp_exception_state^.__eip, 8);
+       end
+     else
+       begin
+          write(stderr, 'FPK ',en);
+          err(' at eip=');
+          itox(djgpp_exception_state^.__eip, 8);
+       end;
+     { Control-C should stop the program also !}
+     {if (signum = $79) then
+       begin
+          err(newline);
+          exit(-1);
+       end;}
+     if ((signum < EXCEPTIONCOUNT) and (has_error[signum]=1)) then
+       begin
+          errorcode := djgpp_exception_state^.__sigmask and $ffff;
+          if(errorcode<>0) then
+            begin
+               err(', error=');
+               itox(errorcode, 4);
+            end;
+       end;
+     err(newline);
+     err('eax=');
+     itox(djgpp_exception_state^.__eax, 8);
+     err(' ebx='); itox(djgpp_exception_state^.__ebx, 8);
+     err(' ecx='); itox(djgpp_exception_state^.__ecx, 8);
+     err(' edx='); itox(djgpp_exception_state^.__edx, 8);
+     err(' esi='); itox(djgpp_exception_state^.__esi, 8);
+     err(' edi='); itox(djgpp_exception_state^.__edi, 8);
+     err(newline);
+     err('ebp='); itox(djgpp_exception_state^.__ebp, 8);
+     err(' esp='); itox(djgpp_exception_state^.__esp, 8);
+     err(' program=');
+     err(paramstr(0)+newline);
+     dump_selector('cs', djgpp_exception_state^.__cs);
+     dump_selector('ds', djgpp_exception_state^.__ds);
+     dump_selector('es', djgpp_exception_state^.__es);
+     dump_selector('fs', djgpp_exception_state^.__fs);
+     dump_selector('gs', djgpp_exception_state^.__gs);
+     dump_selector('ss', djgpp_exception_state^.__ss);
+     err(newline);
+     if (djgpp_exception_state^.__cs = get_cs) then
+       show_call_frame;
+     { must not return !! }
+     if exceptions_on then
+       djgpp_exception_toggle;
+     asm
+        pushw $1
+        call  ___exit
+     end;
+end;
+
+var  signal_list : Array[0..SIGMAX] of SignalHandler;
+ {	/* SIG_DFL = 0 */ }
+
+function signal(sig : longint;func : SignalHandler) : SignalHandler;
+  var temp : SignalHandler;
+
+  begin
+     if ((sig <= 0) or (sig > SIGMAX) or (sig = SIGKILL)) then
+       begin
+          signal:=@SIG_ERR;
+          runerror(201);
+       end;
+     temp := signal_list[sig - 1];
+     signal_list[sig - 1] := func;
+     signal:=temp;
+  end;
+
+
+const signames : array [0..14] of string[4] = (
+   'ABRT',
+   'FPE ',
+   'ILL ',
+   'SEGV',
+   'TERM',
+   'ALRM',
+   'HUP ',
+   'INT ',
+   'KILL',
+   'PIPE',
+   'QUIT',
+   'USR1',
+   'USR2',
+   'NOFP',
+   'TRAP');
+
+
+function _raise(sig : longint) : longint;
+  var temp : SignalHandler;
+  label traceback_exit;
+  begin
+     if(sig <= 0) then
+       exit(-1);
+  if (sig > SIGMAX) then
+    exit(-1);
+  temp:=signal_list[sig - 1];
+  if (temp = SignalHandler(@SIG_IGN)) then
+    exit(0); {			/* Ignore it */ }
+  if (temp = SignalHandler(@SIG_DFL)) then
+    begin
+      traceback_exit:
+      if ((sig >= SIGABRT) and (sig <= SIGTRAP)) then
+        begin
+           err('Exiting due to signal SIG');
+           err(signames[sig-sigabrt]);
+        end
+      else
+        begin
+           err('Exiting due to signal $');
+           itox(sig, 4);
+        end;
+      err(newline);
+      { if(djgpp_exception_state<>nil) then }
+        do_faulting_finish_message();	{/* Exits, does not return */ }
+      exit(-1);
+    end;
+  if ((longint(temp) < longint(starttext)) or (longint(temp) > longint(endtext))) then
+    begin
+       err('Bad signal handler, ');
+       goto traceback_exit;
+    end;
+  temp(sig);
+  exit(0);
+  end;
+
+{ /* This routine must call exit() or jump changing stacks.  This routine is
+   the basis for traceback generation, core creation, signal handling. */ }
+
+{ taken from sysutils.pas }
+    function setjmp(var rec : tjmprec) : longint;
+
+      begin
+         asm
+            pushl %edi
+            movl rec,%edi
+            movl %eax,(%edi)
+            movl %ebx,4(%edi)
+            movl %ecx,8(%edi)
+            movl %edx,12(%edi)
+            movl %esi,16(%edi)
+
+            { load edi }
+            movl -4(%ebp),%eax
+
+            { ... and store it }
+            movl %eax,20(%edi)
+
+            { ebp ... }
+            movl (%ebp),%eax
+            movl %eax,24(%edi)
+
+            { esp ... }
+            movl %esp,%eax
+            addl $12,%eax
+            movl %eax,28(%edi)
+
+            { the return address }
+            movl 4(%ebp),%eax
+            movl %eax,32(%edi)
+
+            { flags ... }
+            pushfl
+            popl 36(%edi)
+
+            { !!!!! the segment registers, not yet needed }
+            { you need them if the exception comes from
+            an interrupt or a seg_move }
+            movw %cs,40(%edi)
+            movw %ds,42(%edi)
+            movw %es,44(%edi)
+            movw %fs,46(%edi)
+            movw %gs,48(%edi)
+            movw %ss,50(%edi)
+
+	    movl ___djgpp_exception_state_ptr, %eax
+	    movl %eax, 60(%edi)
+
+            { restore EDI }
+            pop %edi
+
+            { we come from the initial call }
+            xorl %eax,%eax
+
+            leave
+            ret $4
+         end;
+      end;
+
+const exception_level : longint = 0;
+
+    procedure longjmp({const}var  rec : tjmprec;return_value : longint);
+
+      begin
+         if (@rec=pjmprec(djgpp_exception_state)) and
+            (exception_level>0) then
+           dec(exception_level);
+         asm
+            { restore compiler shit }
+            popl %ebp
+{/* Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details */}
+{/* This is file LONGJMP.S */}
+	movl	4(%esp),%edi	{/* get jmp_buf */}
+	movl	8(%esp),%eax	{/* store retval in j->eax */}
+	movl	%eax,0(%edi)
+
+	movw	46(%edi),%fs
+	movw	48(%edi),%gs
+	movl	4(%edi),%ebx
+	movl	8(%edi),%ecx
+	movl	12(%edi),%edx
+	movl	24(%edi),%ebp
+
+	{/* Now for some uglyness.  The jmp_buf structure may be ABOVE the
+	   point on the new SS:ESP we are moving to.  We don't allow overlap,
+	   but do force that it always be valid.  We will use ES:ESI for
+	   our new stack before swapping to it.  */}
+
+	movw	50(%edi),%es
+	movl	28(%edi),%esi
+	subl	$28,%esi	{/* We need 7 working longwords on stack */}
+
+	movl	60(%edi),%eax
+	es
+	movl	%eax,(%esi)	{/* Exception pointer */}
+
+	movzwl	42(%edi),%eax
+	es
+	movl	%eax,4(%esi)	{/* DS */}
+
+	movl	20(%edi),%eax
+	es
+	movl	%eax,8(%esi)	{/* EDI */}
+
+	movl	16(%edi),%eax
+	es
+	movl	%eax,12(%esi)	{/* ESI */}
+
+	movl	32(%edi),%eax
+	es
+	movl	%eax,16(%esi)	{/* EIP - start of IRET frame */}
+
+	movl	40(%edi),%eax
+	es
+	movl	%eax,20(%esi)	{/* CS */}
+
+	movl	36(%edi),%eax
+	es
+	movl	%eax,24(%esi)	{/* EFLAGS */}
+
+	movl	0(%edi),%eax
+	movw	44(%edi),%es
+
+	movw	50(%edi),%ss
+	movl	%esi,%esp
+
+	popl	___djgpp_exception_state_ptr
+	popl	%ds
+	popl	%edi
+	popl	%esi
+	iret			{/* actually jump to new cs:eip loading flags */}
+         end;
+      end;
+
+
+      procedure djgpp_exception_processor;[public,alias : '___djgpp_exception_processor'];
+    var sig : longint;
+
+    begin
+       inc(exception_level);
+       sig:=djgpp_exception_state^.__signum;
+       if (exception_level=1) or (sig=$78) then
+         begin
+            sig := except_to_sig(sig);
+            _raise(sig);
+            if (djgpp_exception_state^.__signum >= EXCEPTIONCOUNT) then
+            { /* Not exception so continue OK */ }
+              longjmp(pjmprec(djgpp_exception_state)^, djgpp_exception_state^.__eax);
+            {/* User handler did not exit or longjmp, we must exit */}
+            err('FPK cannot continue from exception, exiting due to signal ');
+            itox(sig, 4);
+            err(newline);
+         end
+       else
+         begin
+            if exception_level>2 then
+              begin
+                 err('FPK triple exception, exiting !!! ');
+                 if (exceptions_on) then
+                   djgpp_exception_toggle;
+                 asm
+                    pushw $1
+                    call  ___exit
+                 end;
+              end;
+            err('FPK double exception, exiting due to signal ');
+            itox(sig, 4);
+            err(newline);
+         end;
+       do_faulting_finish_message;
+    end;
+
+type trealseginfo = tseginfo;
+     pseginfo = ^tseginfo;
+
+var except_ori : array [0..EXCEPTIONCOUNT-1] of tseginfo;
+    kbd_ori : tseginfo;
+    npx_ori : tseginfo;
+    cbrk_ori,cbrk_rmcb : trealseginfo;
+    cbrk_regs : registers;
+{/* Routine toggles ALL the exceptions.  Used around system calls, at exit. */}
+
+function djgpp_cbrk_hdlr : pointer;
+  begin
+     asm
+        movl ___djgpp_cbrk_hdlr,%eax
+        movl %eax,__RESULT
+     end;
+  end;
+
+function djgpp_old_kbd : pseginfo;
+  begin
+     asm
+        movl ___djgpp_old_kbd,%eax
+        movl %eax,__RESULT
+     end;
+  end;
+
+procedure djgpp_exception_toggle;
+  var _except : tseginfo;
+      i : longint;
+      local_ex : boolean;
+
+  begin
+{$ifdef DEBUG}
+     if exceptions_on then
+       begin
+          err('Disabling FPK exceptions');
+          err(newline);
+       end
+     else
+       begin
+          err('Enabling FPK exceptions');
+          err(newline);
+       end;
+{$endif DEBUG}
+     { toggle here to avoid infinite recursion }
+     { if a subfunction calls runerror !!      }
+     exceptions_on:= not exceptions_on;
+     local_ex:=exceptions_on;
+     asm
+        movzbl local_ex,%eax
+        movl   %eax,_v2prt0_exceptions_on
+     end;
+     for i:=0 to  EXCEPTIONCOUNT-1 do
+       begin
+          if get_pm_exception_handler(i,_except) then
+            begin
+               if (i <> 2) {or (_crt0_startup_flags & _CRT0_FLAG_NMI_SIGNAL))} then
+               if not set_pm_exception_handler(i,except_ori[i]) then
+                 err('error setting exception nø'+hexstr(i,2));
+               except_ori[i] := _except;
+            end
+          else
+            begin
+               if get_exception_handler(i,_except) then
+                 begin
+                    if (i <> 2) {or (_crt0_startup_flags & _CRT0_FLAG_NMI_SIGNAL))} then
+                    if not set_exception_handler(i,except_ori[i]) then
+                      err('error setting exception nø'+hexstr(i,2));
+                    except_ori[i] := _except;
+                 end
+            end;
+       end;
+     get_pm_interrupt($75, _except);
+     set_pm_interrupt($75, npx_ori);
+     npx_ori:=_except;
+     get_pm_interrupt(9, _except);
+     set_pm_interrupt(9, kbd_ori);
+     kbd_ori := _except;
+{$ifdef UseRMcbrk}
+     if (cbrk_hooked) then
+       begin
+          set_rm_interrupt(cbrk_vect,cbrk_ori);
+          free_rm_callback(cbrk_rmcb);
+          cbrk_hooked := false;
+{$ifdef DEBUG}
+       err('back to ori rm cbrk  '+hexstr(cbrk_ori.segment,4)+':'+hexstr(longint(cbrk_ori.offset),4));
+
+{$endif DEBUG}
+       end
+     else
+       begin
+          get_rm_interrupt(cbrk_vect, cbrk_ori);
+{$ifdef DEBUG}
+       err('ori rm cbrk  '+hexstr(cbrk_ori.segment,4)+':'+hexstr(longint(cbrk_ori.offset),4));
+{$endif DEBUG}
+          get_rm_callback(djgpp_cbrk_hdlr, cbrk_regs, cbrk_rmcb);
+          set_rm_interrupt(cbrk_vect, cbrk_rmcb);
+{$ifdef DEBUG}
+       err('now rm cbrk  '+hexstr(cbrk_rmcb.segment,4)+':'+hexstr(longint(cbrk_rmcb.offset),4));
+{$endif DEBUG}
+          cbrk_hooked := true;
+       end;
+{$endif UseRMcbrk}
+  end;
+
+  function dpmi_set_coprocessor_emulation(flag : longint) : longint;
+
+    var
+       res : longint;
+
+    begin
+       asm
+          movl flag,%ebx
+          movl $0xe01,%eax
+          int $0x31
+          jc .L_coproc_error
+          xorl %eax,%eax
+       .L_coproc_error:
+          movl %eax,res
+       end;
+       dpmi_set_coprocessor_emulation:=res;
+    end;
+
+
+procedure dpmiexcp_exit{(status : longint)};[alias : 'excep_exit'];
+{
+  /* We need to restore hardware interrupt handlers even if somebody calls
+     `_exit' directly, or else we crash the machine in nested programs.
+     We only toggle the handlers if the original keyboard handler is intact
+     (otherwise, they might have already toggled them).  */       }
+  begin
+     if (exceptions_on) then
+       djgpp_exception_toggle;
+     asm
+        xorl %eax,%eax
+        movl %eax,_exception_exit
+        movl %eax,_swap_in
+        movl %eax,_swap_out
+     end;
+     { restore the FPU state }
+     dpmi_set_coprocessor_emulation(1);
+  end;
+
+{ used by dos.pp for swap vectors }
+procedure dpmi_swap_in;[alias : 'swap_in'];
+  begin
+     if not (exceptions_on) then
+       djgpp_exception_toggle;
+  end;
+
+procedure dpmi_swap_out;[alias : 'swap_out'];
+  begin
+     if (exceptions_on) then
+       djgpp_exception_toggle;
+  end;
+
+procedure djgpp_exception_setup;
+
+  var _except,old_kbd : tseginfo;
+      locksize : longint;
+      hw_lock_start, hw_lock_end : longint;
+      i : longint;
+      dossel :word;
+  begin
+     asm
+        movl _exception_exit,%eax
+        xorl %eax,%eax
+        jne  .L_already
+        leal excep_exit,%eax
+        movl %eax,_exception_exit
+        leal swap_in,%eax
+        movl %eax,_swap_in
+        leal swap_out,%eax
+        movl %eax,_swap_out
+     end;
+
+     for i := 0 to  SIGMAX-1 do
+        signal_list[i] := SignalHandler(@SIG_DFL);
+
+     { /* app_DS only used when converting HW interrupts to exceptions */ }
+     asm
+        movw %ds,___djgpp_app_DS
+        movw %ds,___djgpp_our_DS
+        movl $___djgpp_hw_lock_start,%eax
+        movl %eax,hw_lock_start
+        movl $___djgpp_hw_lock_end,%eax
+        movl %eax,hw_lock_end
+     end;
+     dossel := dosmemselector;
+     asm
+        movw dossel,%ax
+        movw %ax,___djgpp_dos_sel
+     end;
+     {/* lock addresses which may see HW interrupts */}
+     { lockmem.address = __djgpp_base_address + (unsigned) &__djgpp_hw_lock_start;}
+     locksize := hw_lock_end - hw_lock_start;
+     lock_code(pointer(hw_lock_start),locksize);
+     _except.segment:=get_cs;
+{        _except.offset:= (unsigned) &__djgpp_exception_table;}
+      asm
+         leal _except,%eax
+         movl $___djgpp_exception_table,(%eax)
+      end;
+
+      for i:=0 to EXCEPTIONCOUNT-1 do
+        begin
+           except_ori[i] := _except;	{/* New value to set */}
+           _except.offset:=_except.offset + 4;	{/* This is the size of push n, jmp */}
+        end;
+
+      kbd_ori.segment := _except.segment;
+      npx_ori.segment := _except.segment;
+           asm
+              leal _NPX_ORI,%eax
+              movl $___djgpp_npx_hdlr,(%eax)
+           end;
+      {npx_ori.offset32:= (unsigned) &__djgpp_npx_hdlr;}
+      if (go32_info_block.linear_address_of_primary_screen <> $a0000) then
+        begin
+           asm
+              leal _KBD_ORI,%eax
+              movl $___djgpp_kbd_hdlr,(%eax)
+           end;
+        {kbd_ori.offset32 = (unsigned) &__djgpp_kbd_hdlr;}
+        end
+      else
+        begin
+           asm
+              leal _KBD_ORI,%eax
+              movl $___djgpp_kbd_hdlr_pc98,(%eax)
+           end;
+           {kbd_ori.offset32 = (unsigned) &__djgpp_kbd_hdlr_pc98;}
+           cbrk_vect := $06;
+           asm
+              leal _except,%eax
+              movl $___djgpp_iret,(%eax)
+           end;
+           {_except.offset32 = (unsigned) &__djgpp_iret;		/* TDPMI98 bug */}
+           set_pm_interrupt($23,_except);
+        end;
+     asm
+        leal _except,%eax
+        movl $___djgpp_i24,(%eax)
+     end;
+     {except.offset32 = (unsigned) &__djgpp_i24;}
+     set_pm_interrupt($24, _except);
+     get_pm_interrupt(9,old_kbd);
+     asm
+        movl $___djgpp_old_kbd,%edi
+        leal old_kbd,%esi
+        movl $6,%ecx { sier of tseginfo }
+        rep
+        movsb
+     end;
+     djgpp_exception_toggle;	{/* Set new values & save old values */}
+
+     {/* get original video mode and save */}
+     old_video_mode := farpeekb(dosmemselector, $449);
+     asm
+        .L_already:
+     end;
+  end;
+
+
+function djgpp_set_ctrl_c(enable : boolean) : boolean;
+  var oldenable : boolean;
+begin
+  asm
+     movb ___djgpp_hwint_flags,%al
+     andb $1,%al
+     movb %al,oldenable
+  end;
+  if (enable) then
+       asm
+         movl ___djgpp_hwint_flags,%eax
+         andl $0xfffe,%eax
+         movl %eax,___djgpp_hwint_flags
+       end
+  else
+       asm
+         movl ___djgpp_hwint_flags,%eax
+         orl $1,%eax
+         movl %eax,___djgpp_hwint_flags
+       end;
+    {__djgpp_hwint_flags |= 1;}
+  djgpp_set_ctrl_c:=oldenable;
+end;
+
+begin
+   asm
+      movl $_etext,_ENDTEXT
+      movl $start,_STARTTEXT
+      movl ___v2prt0_ds_alias,%eax
+      movl %eax,___djgpp_ds_alias
+   end;
+djgpp_exception_setup;
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:42  root
+  Initial revision
+
+  Revision 1.9  1998/03/18 15:34:46  pierre
+    + fpu state is restaured in excep_exit
+      less risk of problems
+
+  Revision 1.8  1998/03/01 18:18:53  carl
+    * bugfix of wrong vector initialization because of incorrect
+      error indexes (were starting at 1 instead of zero in some places).
+
+  Revision 1.7  1998/02/05 17:04:58  pierre
+    * emulation is working with wmemu387.dxe
+
+  Revision 1.6  1998/02/03 15:52:49  pierre
+    * swapvectors really disable exception handling
+      and interrupt redirection with go32v2
+    * in dos.pp bug if arg path from fsearch had a directory part fixed
+
+  Revision 1.5  1998/01/26 11:57:25  michael
+  + Added log at the end
+
+  Revision 1.4  1998/01/16 16:49:12  pierre
+    * Crtl-C did not break the program
+
+}
+
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:42  root
+  Initial revision
+
+  Revision 1.9  1998/03/18 15:34:46  pierre
+    + fpu state is restaured in excep_exit
+      less risk of problems
+
+  Revision 1.8  1998/03/01 18:18:53  carl
+    * bugfix of wrong vector initialization because of incorrect
+      error indexes (were starting at 1 instead of zero in some places).
+
+  Revision 1.7  1998/02/05 17:04:58  pierre
+    * emulation is working with wmemu387.dxe
+
+  Revision 1.6  1998/02/03 15:52:49  pierre
+    * swapvectors really disable exception handling
+      and interrupt redirection with go32v2
+    * in dos.pp bug if arg path from fsearch had a directory part fixed
+
+  Revision 1.5  1998/01/26 11:57:25  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/dos/go32v2/dpmiexcp.pp
+  description:
+  ----------------------------
+  revision 1.4
+  date: 1998/01/16 16:49:12;  author: pierre;  state: Exp;  lines: +8 -3
+    * Crtl-C did not break the program
+  ----------------------------
+  revision 1.3
+  date: 1997/12/12 13:14:38;  author: pierre;  state: Exp;  lines: +40 -4
+     + added handling of swap_vectors if under exceptions
+       i.e. swapvector is not dummy under go32v2
+     * bug in output, exceptions where not allways reset correctly
+       now the code in dpmiexcp is called from v2prt0.as exit routine
+     * in crt.pp corrected init_delay calibration loop
+       and added it for go32v2 also (was disabled before due to crashes !!)
+       the previous code did a wrong assumption on the time need to call
+       get_ticks compared to an internal loop without call
+  ----------------------------
+  revision 1.2
+  date: 1997/12/01 12:26:08;  author: michael;  state: Exp;  lines: +14 -3
+  + added copyright reference in header.
+  ----------------------------
+  revision 1.1
+  date: 1997/11/27 08:33:52;  author: michael;  state: Exp;
+  Initial revision
+  ----------------------------
+  revision 1.1.1.1
+  date: 1997/11/27 08:33:52;  author: michael;  state: Exp;  lines: +0 -0
+  FPC RTL CVS start
+  =============================================================================
+}

rtl/dos/go32v2/dxeload.pp

@@ -0,0 +1,142 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by Pierre Muller,
+    member of the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+{ Translated to FPK pascal by Pierre Muller,
+without changing the fpu.s file }
+{
+/* Copyright (C) 1994, 1995 Charles Sandmann ([email protected])
+ * FPU setup and emulation hooks for DJGPP V2.0
+ * This file maybe freely distributed, no warranty. */
+this file has been translated from
+  dxe.h
+  dxeload.c
+  npxsetup.c
+  it uses fpu.as unchanged from fpu.s in DJGPP/SRC/LIBC/}
+
+{/* Copyright (C) 1995 Charles Sandmann ([email protected])
+   This software may be freely distributed with above copyright, no warranty.
+   Based on code by DJ Delorie, it's really his, enhanced, bugs fixed. */}
+
+
+Unit dxeload;
+
+  interface
+
+    type
+       dxe_header = record
+                      magic : longint;
+                      symbol_offset : longint;
+                      element_size : longint;
+                      nrelocs : longint;
+                    end;
+
+    const
+       DXE_MAGIC  = $31455844;
+
+{/* data stored after dxe_header in file; then relocs, 4 bytes each */}
+
+    function dxe_load(filename : string) : pointer;
+
+  implementation
+
+    function dxe_load(filename : string) : pointer;
+
+      type
+          pointer_array = array[0..0] of pointer;
+          tpa = ^pointer_array;
+          plongint = ^longint;
+          ppointer = ^pointer;
+      var
+         dh : dxe_header;
+         data : pchar;
+         f : file;
+         relocs : tpa;
+         i : longint;
+	      addr : plongint;
+
+      begin
+         dxe_load:=nil;
+         assign(f,filename);
+         reset(f,1);
+         blockread(f,@dh,sizeof(dxe_header));
+         if dh.magic<>DXE_MAGIC then
+           begin
+              close(f);
+              exit;
+           end;
+
+         { get memory for code }
+         getmem(data,dh.element_size);
+         if data=nil then
+           exit;
+         { get memory for relocations }
+         getmem(relocs,dh.nrelocs*sizeof(pointer));
+         if relocs=nil then
+           begin
+              freemem(data,dh.element_size);
+              exit;
+           end;
+         { copy code }
+         blockread(f,data^,dh.element_size);
+         blockread(f,relocs^,dh.nrelocs*sizeof(pointer));
+
+         { relocate internal references }
+         for i:=0 to dh.nrelocs-1 do
+           begin
+              cardinal(addr):=cardinal(data)+cardinal(relocs^[i]);
+              addr^:=addr^+pointer(data);
+           end;
+         dxe_load:=pointer( dh.symbol_offset + cardinal(data));
+      end;
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:42  root
+  Initial revision
+
+  Revision 1.3  1998/01/26 11:57:29  michael
+  + Added log at the end
+
+  Revision 1.2  1998/01/19 17:04:39  pierre
+    * bug in dxe loading corrected, emu still does not work !!
+
+  Revision 1.1  1998/01/16 16:50:49  pierre
+      dxeload is a pascal version of the DJGPP C dxe loader
+
+}
+
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:42  root
+  Initial revision
+
+  Revision 1.3  1998/01/26 11:57:29  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/dos/go32v2/dxeload.pp
+  description:
+  ----------------------------
+  revision 1.2
+  date: 1998/01/19 17:04:39;  author: pierre;  state: Exp;  lines: +7 -3
+    * bug in dxe loading corrected, emu still does not work !!
+  ----------------------------
+  revision 1.1
+  date: 1998/01/16 16:50:49;  author: pierre;  state: Exp;
+      dxeload is a pascal version of the DJGPP C dxe loader
+  =============================================================================
+}

rtl/dos/go32v2/emu387.pp

@@ -0,0 +1,257 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by Pierre Muller,
+    member of the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+{ Translated to FPK pascal by Pierre Muller,
+without changing the fpu.s file }
+{
+/* Copyright (C) 1994, 1995 Charles Sandmann ([email protected])
+ * FPU setup and emulation hooks for DJGPP V2.0
+ * This file maybe freely distributed, no warranty. */
+this file has been translated from
+  npxsetup.c  }
+
+unit emu387;
+
+  interface
+
+    procedure npxsetup(prog_name : string);
+
+  implementation
+
+    uses dos, dxeload, dpmiexcp;
+
+  type
+     emu_entry_type = function(exc : pexception_state) : longint;
+
+  var
+     _emu_entry : emu_entry_type;
+
+
+  procedure _control87(mask1,mask2 : word);
+
+    begin
+{/* Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details */}
+{ from file cntrl87.s in src/libc/pc_hw/fpu }
+        asm
+           { make room on stack }
+           pushl   %eax
+           fstcw   (%esp)
+           fwait
+           popl    %eax
+           andl    $0xffff, %eax
+           { OK;  we have the old value ready }
+
+           movl    mask2, %ecx
+           notl    %ecx
+           andl    %eax, %ecx      /* the bits we want to keep */
+
+           movl    mask2, %edx
+           andl    mask1, %edx      /* the bits we want to change */
+
+           orl     %ecx, %edx      /* the new value */
+           pushl   %edx
+           fldcw   (%esp)
+           popl    %edx
+        end;
+    end;
+
+     { the problem with the stack that is not cleared }
+  function emu_entry(exc : pexception_state) : longint;
+
+    begin
+       emu_entry:=_emu_entry(exc);
+    end;
+
+  function nofpsig( sig : longint) : longint;
+    var res : longint;
+    const
+       last_eip : longint = 0;
+
+    begin
+       {if last_eip=djgpp_exception_state^.__eip then
+         begin
+            writeln('emu call two times at same address');
+            dpmi_set_coprocessor_emulation(1);
+            _raise(SIGFPE);
+            exit(0);
+         end; }
+
+       last_eip:=djgpp_exception_state^.__eip;
+       res:=emu_entry(djgpp_exception_state);
+       if res<>0 then
+         begin
+            writeln('emu call failed. res = ',res);
+            dpmi_set_coprocessor_emulation(1);
+            _raise(SIGFPE);
+            exit(0);
+         end;
+       longjmp(pjmprec(djgpp_exception_state)^, djgpp_exception_state^.__eax);
+       nofpsig:=0;
+    end;
+
+  var
+     prev_exit : pointer;
+
+  procedure restore_DPMI_fpu_state;
+    begin
+       exitproc:=prev_exit;
+       dpmi_set_coprocessor_emulation(1);
+       writeln('Coprocessor restored ');
+       {/* Enable Coprocessor, no exceptions */}
+    end;
+
+ { function _detect_80387 : boolean;[C];
+  not used because of the underscore problem }
+
+{$L fpu.o }
+
+  procedure npxsetup(prog_name : string);
+
+    var
+       cp : string;
+       i : byte;
+       have_80387 : boolean;
+       emu_p : pointer;	
+    const
+       veryfirst : boolean = True;
+
+    begin
+      cp:=getenv('387');
+      if (length(cp)>0) and (upcase(cp[1])='N') then
+        have_80387:=False
+      else
+        begin
+           dpmi_set_coprocessor_emulation(1);
+           asm
+              call __detect_80387
+              movb %al,have_80387
+           end;
+        end;
+      if (length(cp)>0) and (upcase(cp[1])='Q') then
+        begin
+           if not have_80387 then
+             write(stderr,'No ');
+           writeln(stderr,'80387 detected.');
+        end;
+
+      if have_80387 then
+      {/* mask all exceptions, except invalid operation */}
+        _control87($033e, $ffff)
+      else
+        begin
+           {/* Flags value 3 means coprocessor emulation, exceptions to us */}
+           if (dpmi_set_coprocessor_emulation(3)<>0) then
+             begin
+                writeln(stderr,'Warning: Coprocessor not present and DPMI setup failed!');
+                writeln(stderr,'         If application attempts floating operations system may hang!');
+             end
+           else
+             begin
+                cp:=getenv('EMU387');
+                if length(cp)=0 then
+                  begin
+                     for i:=length(prog_name) downto 1 do
+                       if (prog_name[i]='\') or (prog_name[i]='/') then
+                         break;
+                     if i>1 then
+                       cp:=copy(prog_name,1,i);
+                     cp:=cp+'wmemu387.dxe';
+                  end;
+                emu_p:=dxe_load(cp);
+                _emu_entry:=emu_entry_type(emu_p);
+                if (emu_p=nil) then
+                  begin
+                     writeln(cp+' load failed !');
+                     halt;
+                  end;
+                if veryfirst then
+                  begin
+                     veryfirst:=false;
+                     prev_exit:=exitproc;
+                     exitproc:=@restore_DPMI_fpu_state;
+                  end;
+                signal(SIGNOFP,@nofpsig);
+             end;
+        end;
+    end;
+
+begin
+   npxsetup(paramstr(0));
+end.
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:42  root
+  Initial revision
+
+  Revision 1.6  1998/03/18 15:34:46  pierre
+    + fpu state is restaured in excep_exit
+      less risk of problems
+
+  Revision 1.5  1998/02/05 17:24:09  pierre
+    * bug in assembler code
+    * changed default name to wmemu387.dxe
+
+  Revision 1.4  1998/02/05 17:04:59  pierre
+    * emulation is working with wmemu387.dxe
+
+  Revision 1.3  1998/01/26 11:57:34  michael
+  + Added log at the end
+
+  Revision 1.2  1998/01/19 17:04:40  pierre
+    * bug in dxe loading corrected, emu still does not work !!
+
+  Revision 1.1  1998/01/16 16:53:15  pierre
+      emu387 is a program based on npxset from DJGPP
+      that loads the emu387.dxe if no FPU is present
+      or if the env var 387 is set to N
+
+}
+
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:42  root
+  Initial revision
+
+  Revision 1.6  1998/03/18 15:34:46  pierre
+    + fpu state is restaured in excep_exit
+      less risk of problems
+
+  Revision 1.5  1998/02/05 17:24:09  pierre
+    * bug in assembler code
+    * changed default name to wmemu387.dxe
+
+  Revision 1.4  1998/02/05 17:04:59  pierre
+    * emulation is working with wmemu387.dxe
+
+  Revision 1.3  1998/01/26 11:57:34  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/dos/go32v2/emu387.pp
+  description:
+  ----------------------------
+  revision 1.2
+  date: 1998/01/19 17:04:40;  author: pierre;  state: Exp;  lines: +11 -2
+    * bug in dxe loading corrected, emu still does not work !!
+  ----------------------------
+  revision 1.1
+  date: 1998/01/16 16:53:15;  author: pierre;  state: Exp;
+      emu387 is a program based on npxset from DJGPP
+      that loads the emu387.dxe if no FPU is present
+      or if the env var 387 is set to N
+  =============================================================================
+}

rtl/dos/go32v2/exceptn.as

@@ -0,0 +1,427 @@
+/* Copyright (C) 1994, 1995 Charles Sandmann ([email protected])
+ * This file maybe freely distributed and modified as long as copyright remains.
+ */
+/* Simply rewritten to be compiled directly by GNU as by Pierre Muller
+   for use in FPC the free pascal compiler */
+  EAX = 0
+  EBX = 4
+  ECX = 8
+  EDX = 12
+  ESI = 16
+  EDI = 20
+  EBP = 24
+  ESP = 28
+  EIP = 32
+  EFLAGS = 36
+  CS = 40
+  DS = 42
+  ES = 44
+  FS = 46
+  GS = 48
+  SS = 50
+  ERRCODE = 52
+  EXCEPNO = 56
+  PREVEXC = 60
+
+  /* Length 64 bytes plus non-used FPU */
+	.data
+	.align 4
+	.lcomm	exception_stack, 8000
+
+	.text
+	.align	4
+   .macro EXCEPTION_ENTRY number
+	pushl	\number
+	jmp	exception_handler
+   .endm
+
+	.global	___djgpp_exception_table
+___djgpp_exception_table:
+EXCEPTION_ENTRY $0
+EXCEPTION_ENTRY $1
+EXCEPTION_ENTRY $2
+EXCEPTION_ENTRY $3
+EXCEPTION_ENTRY $4
+EXCEPTION_ENTRY $5
+EXCEPTION_ENTRY $6
+EXCEPTION_ENTRY $7
+EXCEPTION_ENTRY $8
+EXCEPTION_ENTRY $9
+EXCEPTION_ENTRY $10
+EXCEPTION_ENTRY $11
+EXCEPTION_ENTRY $12
+EXCEPTION_ENTRY $13
+EXCEPTION_ENTRY $14
+EXCEPTION_ENTRY $15
+EXCEPTION_ENTRY $16
+EXCEPTION_ENTRY $17
+
+/*	This code is called any time an exception occurs in the 32 bit protected
+;*	mode code.  The exception number is pushed on the stack.  This is called
+;*	on a locked stack with interrupts disabled.  Don't try to terminate.
+;*
+;*	[   *	|   SS  ]	* Don't modify
+;*	[      ESP      ]
+;*	[    EFLAGS	]
+;*	[   *   |   CS	]	* Don't modify
+;*	[      EIP	]
+;*	[   ERR CODE	]
+;*	[   *   |RET CS*]	* Don't modify
+;*	[   RET EIP*	]	* Don't modify
+;*	[  EXCEPTION #	]	(And later EBP)
+;*/
+exception_handler:
+	pushl	%ebx
+	pushl	%ds
+   	.byte	0x2e				/* CS: */
+	cmpb	$0, forced
+	je	not_forced
+	call	limitFix
+   	.byte	0x2e				/* CS: */
+	movzbl	forced,%ebx
+	movl	%ebx,8(%esp)			/* replace EXCEPNO */
+not_forced:
+	movw	%cs:___djgpp_our_DS, %ds
+	movl	$0x10000, forced		/* its zero now, flag inuse */
+	movl	$exception_state, %ebx
+	popl	DS(%ebx)
+	popl	EBX(%ebx)
+	popl	EXCEPNO(%ebx)
+	movl	%esi, ESI(%ebx)
+	movl	%edi, EDI(%ebx)
+	movl	%ebp, EBP(%ebx)
+	movl	%eax, EAX(%ebx)
+	movl	%ecx, ECX(%ebx)
+	movl	%edx, EDX(%ebx)
+	movw	%es, ES(%ebx)
+	movw	%fs, FS(%ebx)
+	movw	%gs, GS(%ebx)
+	movl	___djgpp_exception_state_ptr, %eax
+	movl	%eax, PREVEXC(%ebx)
+
+/* Stack clean at this point, DS:[EBX] points to exception_state, all 
+   register information saved.  Now get the info on stack. */
+
+	pushl	%ebp
+	movl	%esp, %ebp	/* load ebp with stack for easy access */
+	
+	movl	12(%ebp), %eax
+	movl	%eax, ERRCODE(%ebx)
+	movl	16(%ebp), %eax
+	movl	%eax, EIP(%ebx)
+	movl	20(%ebp), %eax
+	movw	%ax, CS(%ebx)
+	movl	24(%ebp), %eax
+	movl	%eax, EFLAGS(%ebx)
+	andb	$0xfe, %ah			/* Clear trace flag */
+	movl	%eax, 24(%ebp)			/* and restore on stack */
+
+	movl	28(%ebp), %eax
+	movl	%eax, ESP(%ebx)
+	movl	32(%ebp), %eax
+	movw	%ax, SS(%ebx)
+
+	movl	$dpmi_exception_proc1, 16(%ebp)		/* where to return */
+	movw	%cs, 20(%ebp)
+
+/* Change to our local stack on return from exception (maybe stack exception) */
+	movw	%ds, %ax
+	cmpb	$12,EXCEPNO(%ebx)		/* Stack fault ? */
+	je	1f
+	cmpw	%ax,32(%ebp)
+	je	stack_ok
+1:	movl	$exception_stack+8000, 28(%ebp)
+	movw	%ax, 32(%ebp)
+stack_ok:
+/* Now copy the exception structure to the new stack before returning */
+	movw	%ax, %es
+	movl	%ebx,%esi
+	movl	28(%ebp), %edi
+	subl	$92, %edi			/* 64 plus extra for longjmp */
+	movl	%edi, 28(%ebp)
+	movl	%edi, ___djgpp_exception_state_ptr
+	movl	$16, %ecx
+	cld
+	rep
+	movsl
+
+	movl	EAX(%ebx), %eax				/* restore regs */
+	movl	ESI(%ebx), %esi
+	movl	EDI(%ebx), %edi
+	movl	ECX(%ebx), %ecx
+	movw	ES(%ebx), %es
+	popl	%ebp
+	pushl	EBX(%ebx)
+	pushl	DS(%ebx)
+	movb	$0, forced+2				/* flag non-use */
+	popl	%ds
+	popl	%ebx
+	lret
+
+/* Code to fix fake exception, EBX destroyed.  Note, app_DS may == our_DS! */
+	.align 4
+limitFix:
+	pushl	%eax
+	pushl	%ecx
+	pushl	%edx
+   	.byte	0x2e				/* CS: */
+	movl	___djgpp_app_DS, %ebx		/* avoid size prefix */
+   	.byte	0x2e				/* CS: */
+	movl	ds_limit, %edx
+	movl	%edx, %ecx
+	shrl	$16, %ecx
+	movw	$0x0008, %ax
+	int	$0x31				/* Set segment limit */
+	popl	%edx
+	popl	%ecx
+	popl	%eax
+	ret
+
+/* This local routine preprocesses a return request to the C code.  It checks
+   to make sure the DS & SS are set OK for C code.  If not, it sets them up */
+	.align	4
+dpmi_exception_proc1:
+	cld
+   	.byte	0x2e				/* CS: !!! */
+	movw	___djgpp_our_DS, %bx		/* to be sure */
+	movw	%bx, %ds
+	movw	%bx, %es
+	/* Note: SS:ESP should be set properly by exception routine */
+	jmp	___djgpp_exception_processor
+
+/*	This code is called by a user routine wishing to save an interrupt
+;*	state.  It will return with a clean stack, our DS,ES,SS.
+;*      Minor bug: uses static exception_state for a short window without
+;*      interrupts guaranteed disabled.
+;*
+;*	[    EFLAGS	]
+;*	[   *   |   CS	]
+;*	[      EIP	]
+;*	[  CALLING EIP  ]
+;*/
+
+	.align	4
+	.globl	___djgpp_save_interrupt_regs
+___djgpp_save_interrupt_regs:
+	pushl	%esi
+	pushl	%ds
+	movw	%cs:___djgpp_our_DS, %ds
+	movl	$exception_state, %esi
+	popl	DS(%esi)		/* Trashes ES but OK */
+	popl	ESI(%esi)
+	movl	%edi, EDI(%esi)
+	movl	%ebp, EBP(%esi)
+	movl	%eax, EAX(%esi)
+	movl	%ebx, EBX(%esi)
+	movl	%ecx, ECX(%esi)
+	movl	%edx, EDX(%esi)
+	popl	%edx			/* Save calling EIP */
+	popl	EIP(%esi)
+	popl	%eax
+	movw	%ax,CS(%esi)		/* Don't pop, nukes DS */
+	popl	EFLAGS(%esi)
+	movl	%esp, ESP(%esi)
+	movw	%es, ES(%esi)
+	movw	%fs, FS(%esi)
+	movw	%gs, GS(%esi)
+	movw	%ss, SS(%esi)
+	movl	___djgpp_exception_state_ptr, %eax
+	movl	%eax, PREVEXC(%esi)
+	cld
+	movw	%ds, %ax
+	movw	%ax, %es
+	movw	%ss, %bx
+	cmpw	%ax, %bx			/* is SS = DS ? */
+	je	Lss_ok
+	movw	%ax, %ss			/* set new SS:ESP */
+	movl	$exception_stack+8000, %esp
+Lss_ok:	subl	$92, %esp		/* 64 plus extra for longjmp */
+	movl	%esp, %edi
+	movl	$16, %ecx
+	movl	%edi, ___djgpp_exception_state_ptr
+	rep
+	movsl					/* Copy structure to stack */
+	jmp	*%edx				/* A "return" */
+
+	.align	4		/* We will touch this; it must be locked */
+	.global ___djgpp_hw_lock_start
+___djgpp_hw_lock_start:
+ds_limit:			.long	0
+forced:				.long	0
+	.global	___djgpp_cbrk_count
+___djgpp_cbrk_count:		.long	0
+	.global	___djgpp_timer_countdown
+___djgpp_timer_countdown:	.long	0
+	.global	___djgpp_our_DS
+___djgpp_our_DS:		.word	0
+	.global	___djgpp_app_DS
+___djgpp_app_DS:		.word	0
+	.global	___djgpp_dos_sel
+___djgpp_dos_sel:		.word	0
+	.global	___djgpp_hwint_flags
+___djgpp_hwint_flags:		.word	0
+	.global	___djgpp_old_kbd
+___djgpp_old_kbd:		.long	0,0
+	.global	___djgpp_old_timer
+___djgpp_old_timer:		.long	0,0
+	.global	___djgpp_exception_state_ptr
+___djgpp_exception_state_ptr:	.long	0
+exception_state:		.space	64
+	.global	___djgpp_ds_alias
+___djgpp_ds_alias:		.word	0	/* used in dpmi/api/d0303.s (alloc rmcb) */
+
+	.align 4
+	.global	___djgpp_npx_hdlr
+___djgpp_npx_hdlr:
+	pushl	%eax
+	xorl	%eax,%eax
+	outb	%al,$0x0f0
+	movb	$0x20,%al
+	outb	%al,$0x0a0
+	outb	%al,$0x020
+	movb	$0x75,%al
+hw_to_excp:
+	call	___djgpp_hw_exception
+	popl	%eax
+	sti
+	iret
+
+	.align 4
+	.global	___djgpp_kbd_hdlr
+___djgpp_kbd_hdlr:
+	pushl	%eax
+	pushl	%ds
+   	.byte	0x2e				/* CS: */
+	testb	$1, ___djgpp_hwint_flags	/* Disable? */
+	jne	Lkbd_chain
+/* Check CTRL state */
+	movw	%cs:___djgpp_dos_sel, %ds	/* Conventional mem selector */
+/*	movw	$0x7021,0xb0f00		*/	/* Test code - write to mono */
+	testb	$4,0x417			/* Test KB flags: CTRL down? */
+	je	Lkbd_chain
+	testb	$8,0x417			/* Test KB flags: ALT down? */
+	jne	Lkbd_chain			/* Don't capture ALT-CTRL-C */
+/* Check port for scan code */
+	inb	$0x60,%al
+	cmpb	$0x2e,%al
+	jne	Lkbd_chain
+/* Clear interrupt, (later: remove byte from controller?)
+	movb	$0x20,%al
+	outb	%al,$0x020	*/
+98:
+	movb	$0x79,%al
+	call	___djgpp_hw_exception
+Lkbd_chain:
+	popl	%ds
+	popl	%eax
+	ljmp	%cs:___djgpp_old_kbd
+
+	.align 4
+	.global	___djgpp_kbd_hdlr_pc98
+___djgpp_kbd_hdlr_pc98:
+	pushl	%eax
+	pushl	%ds
+   	.byte	0x2e				/* CS: */
+	testb	$1, ___djgpp_hwint_flags	/* Disable? */
+	jne	Lkbd_chain
+/* Check CTRL state */
+	movw	%cs:___djgpp_dos_sel, %ds	/* Conventional mem selector */
+	testb	$0x10,0x053a			/* Test KB flags: CTRL down? */
+	jz	Lkbd_chain
+/* Check for scan code */
+	testb	$0x08,0x052f			/* test KB "C" down for PC98 */
+	jz	Lkbd_chain
+	jmp	98b
+
+	.align 4
+	.global	___djgpp_timer_hdlr
+___djgpp_timer_hdlr:
+   	.byte	0x2e				/* CS: */
+	cmpl	$0,___djgpp_timer_countdown
+	je	4f
+	pushl	%ds
+	movw	%cs:___djgpp_ds_alias, %ds
+	decl	___djgpp_timer_countdown
+	popl	%ds
+	jmp	3f
+4:
+	pushl	%eax
+	movb	$0x78,%al
+	call	___djgpp_hw_exception
+	popl	%eax
+3:
+   	.byte	0x2e				/* CS: */
+	testb	$4, ___djgpp_hwint_flags	/* IRET or chain? */
+	jne	2f
+	ljmp	%cs:___djgpp_old_timer
+2:
+	pushl	%eax
+	movb	$0x20,%al			/* EOI the interrupt */
+	outb	%al,$0x020
+	popl	%eax
+	iret
+
+	/* On entry ES is the DS alias selector */
+	.align 4
+	.global	___djgpp_cbrk_hdlr		/* A RMCB handler for 0x1b */
+___djgpp_cbrk_hdlr:
+	cld
+	lodsl					/* EAX = DS:[esi] CS:IP */
+	movl	%eax, %es:0x2a(%edi)		/* store in structure */
+	lodsl					/* AX = FLAGS */
+	movw	%ax, %es:0x20(%edi)
+	addw	$6, %es:0x2e(%edi)		/* Adjust RM SP */
+	movb	$0x1b,%al
+
+   	.byte	0x2e				/* CS: */
+	testb	$2, ___djgpp_hwint_flags	/* Count, don't kill */
+	jne	1f
+
+	call	___djgpp_hw_exception
+	iret
+1:
+	incl	%es:___djgpp_cbrk_count
+	iret
+
+	.global	___djgpp_i24			/* Int 24 handler if needed */
+	.global	___djgpp_iret			/* Int 23 handler if needed */
+___djgpp_i24:
+	movb	$3,%al
+___djgpp_iret:
+	iret
+
+/* Code to stop execution ASAP, EAX destroyed.  Make DS/ES/SS invalid. 
+   Fake exception value is passed in AL and moved into the "forced" variable.
+   This is used to convert a HW interrupt into something we can transfer
+   control away from via longjmp or exit(), common with SIGINT, SIGFPE, or
+   if we want EIP information on timers. */
+
+	.align 4
+	.global	___djgpp_hw_exception
+___djgpp_hw_exception:
+   	.byte	0x2e				/* CS: */
+	cmpl	$0, forced			/* Already flagged? */
+	jne	already_forced
+	pushl	%ebx
+	pushl	%ecx
+	pushl	%edx
+	pushl	%ds
+	movw	%cs:___djgpp_our_DS, %ds
+	movl	___djgpp_app_DS, %ebx		/* avoid size prefix */
+	lsl	%ebx, %ecx
+	movl	%ecx, ds_limit			/* Save current limit */
+	movb	%al, forced			/* Indicate a fake exception */
+	xorl	%ecx, %ecx
+	movw	$0xfff, %dx			/* 4K limit is null page ! */
+	movw	$0x0008, %ax
+	int	$0x31				/* Set segment limit */
+5:	popl	%ds
+	popl	%edx
+	popl	%ecx
+	popl	%ebx
+already_forced:
+	ret
+
+	.global ___djgpp_hw_lock_end
+___djgpp_hw_lock_end:
+	ret					/* LD does weird things */

rtl/dos/go32v2/exit16.ah

@@ -0,0 +1 @@
+	.byte	0xb8,0x01,0x00,0xcd,0x31,0xb8,0x02,0x05,0xcd,0x31,0x88,0xd0,0xb4,0x4c,0xcd,0x21

rtl/dos/go32v2/exit16.asm

@@ -0,0 +1,22 @@
+; Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details
+;-----------------------------------------------------------------------------
+;  exit 16-bit helper
+;
+;  Used to clean up 32-bit arena on exit, so as to release as many
+;  selectors and as much memory as possible.
+;
+;  Call with:	BX = 32-bit CS to free
+;		SI:DI = 32-bit memory handle to free
+;		DL = exit status
+
+	.type	"bin"
+
+	mov	ax, 0x0001
+	int	0x31
+
+	mov	ax, 0x0502
+	int	0x31
+
+	mov	al, dl
+	mov	ah, 0x4c
+	int	0x21

rtl/dos/go32v2/fpu.as

@@ -0,0 +1,49 @@
+/* Copyright (C) 1995 DJ Delorie, see COPYING.DJ for details */
+/* Translated from tasm to GAS by C. Sandmann */
+/* One comment displaced to get it compiled by as.exe directly  !!! */
+/* by Pierre Muller */
+
+/* This routine assumes DS == SS since [ESI] coding shorter than [EBP] coding */
+
+	.global	__detect_80387		/* direct from the Intel manual */
+__detect_80387:				/* returns 1 if 387 (or more), else 0 */
+	pushl	%esi
+	pushl	%eax			/* Dummy work area on stack */
+	movl	%esp,%esi
+	fninit
+	movw	$0x5a5a,(%esi)
+	fnstsw	(%esi)
+	cmpb	$0,(%esi)
+	jne	Lno_387
+	
+	fnstcw	(%esi)
+	movl	(%esi),%eax		/* Only ax significant */
+	andl	$0x103f,%eax
+	cmpl	$0x3f,%eax
+	jne	Lno_387
+	
+	fld1
+	fldz
+/*	fdiv				   GAS encodes this as 0xdcf1 !! BUG */
+	.byte	0xde,0xf9
+	fld	%st
+	fchs
+	fcompp
+	fstsw	(%esi)
+	movzwl	(%esi),%eax		/* Clears upper %eax */
+	sahf
+	je	Lno_387
+	fninit				/* 387 present, initialize. */
+	fnstcw	(%esi)
+	wait
+	andw	$0x0fffa,(%esi)		
+/* enable invalid operation exception */
+	fldcw	(%esi)
+	movw	$1,%eax
+	jmp	Lexit
+Lno_387:
+	xorl	%eax,%eax
+Lexit:
+	popl	%esi			/* Fix stack first */
+	popl	%esi
+	ret

rtl/dos/go32v2/makefile

@@ -0,0 +1,295 @@
+# Makefile for the DOS Go32v2 Run-time library.
+# we need the stupid copies and del because the old FPK Pascal doesn't handle
+# ppc386 ..\crt correct..
+#
+#####################################################################
+# Start of configurable section.
+# Please note that all these must be set in the main makefile, and
+# should be set there.
+# Don't remove the indef statements. They serve to avoid conflicts
+# with the main makefile.
+#####################################################################
+
+# set the directory where to install the units.
+ifndef UNITINSTALLDIR
+UNITINSTALLDIR=c:\lib\ppc
+endif
+
+# set the directory where to install libraries
+ifndef LIBINSTALLDIR
+LIBINSTALLDIR=c:\lib
+endif
+
+# What is the Operating System
+ifndef OS_SRC
+OS_SRC=GO32V2
+endif
+
+# What is the target operating system ?
+ifndef OS_TARGET
+OS_TARGET=GO32V2
+endif
+
+# What compiler to use ?
+# I think ppc386 is better (it's mostly in path) (FK)
+ifndef PP
+PP=ppc386
+endif
+
+# What options to pass to the compiler ?
+# You may want to specify a config file or error definitions file here.
+ifndef OPT
+OPT=
+endif
+
+# Where is the ppumove program ?
+ifndef PPUMOVE
+PPUMOVE=ppumove
+endif
+
+#####################################################################
+# End of configurable section.
+# Do not edit after this line.
+#####################################################################
+
+# Where are the include files
+INC=../../inc
+
+ifndef CPU
+CPU=i386
+endif
+
+PROCINC=../../$(CPU)
+
+# Where are the .ppi files.
+PPI=../ppi
+
+ifeq ($(OS_TARGET),$(OS_SRC))
+CROSSCOMPILE=NO
+else
+CROSSCOMPILE=YES
+endif
+
+# To copy pograms
+ifndef COPY
+COPY=cp -p
+endif
+
+# To delete programs
+ifndef DEL
+ifeq ($(DOS),YES)
+DEL=del
+else
+DEL=rm
+endif
+endif
+
+# To install programs
+ifndef INSTALL
+ifeq ($(DOS),YES)
+INSTALL=cp
+else
+INSTALL=install -m 644
+endif
+endif
+
+
+ifndef MKDIR
+ifeq ($(DOS),YES)
+MKDIR=mkdir
+else
+MKDIR=install -m 755 -d
+endif
+endif
+
+# Check for crosscompile
+ifeq ($(CROSSCOMPILE),YES)
+OPT:=$(OPT) -dCROSSCOMPILE -T$(OS_TARGET)
+endif
+
+# check config file
+ifdef CFGFILE
+OPT:=$(OPT) @$(CFGFILE)
+endif
+
+# to be sure to be able to compile with an older
+# compiler version
+OPT:=$(OPT) -dFPC 
+
+# diff program
+ifndef REFPATH
+REFPATH=h:/cvs/rtl
+endif
+ifndef DIFF
+DIFF=diff
+endif
+ifndef DIFFOPTS
+DIFFOPTS=-b -c
+endif
+
+# os independent depends
+SYSTEMDEPS=$(INC)/system.inc $(INC)/systemh.inc $(INC)/mathh.inc $(INC)/real2str.inc \
+	$(INC)/heaph.inc $(INC)/innr.inc $(INC)/sstrings.inc $(INC)/file.inc \
+	$(INC)/text.inc $(INC)/typefile.inc $(INC)/version.inc $(INC)/filerec.inc \
+	$(INC)/textrec.inc $(INC)/objpas.inc $(INC)/objpash.inc \
+	$(PROCINC)/math.inc $(PROCINC)/set.inc $(PROCINC)/heap.inc $(PROCINC)/$(CPU).inc
+
+PPUEXT=.ppu
+PPLEXT=.ppl
+# At this moment only static libs under go32v2. When shared libs are made then
+# we should ask what kind of lib user wants, and then set the correct
+# extension... (see linux makefile for example)
+LIBEXT=.a
+OEXT=.o
+
+.PHONY: all clean install diffs diffclean
+
+all : system$(PPUEXT) prt0$(OEXT) crt$(PPUEXT) go32$(PPUEXT) strings$(PPUEXT) \
+	dos$(PPUEXT) printer$(PPUEXT) objects$(PPUEXT) \
+	mouse$(PPUEXT) fmouse$(PPUEXT) getopts$(PPUEXT) graph$(PPUEXT) \
+	dpmiexcp$(PPUEXT) exceptn$(OEXT) profile$(PPUEXT) \
+	dxeload$(PPUEXT) fpu$(OEXT) emu387$(PPUEXT) mmx$(PPUEXT) cpu$(PPUEXT) \
+        objpas$(PPUEXT)
+
+dxeload$(PPUEXT) : system$(PPUEXT)
+	$(PP) $(OPT) dxeload $(REDIR)
+
+emu387$(PPUEXT) : system$(PPUEXT) fpu$(OEXT) dxeload$(PPUEXT) dpmiexcp$(PPUEXT)
+	$(PP) $(OPT) emu387 $(REDIR)
+
+fpu$(OEXT) : fpu.as
+	as -o fpu$(OEXT) fpu.as
+
+printer$(PPUEXT) : ../printer.pp system$(PPUEXT)
+	$(COPY) ../printer.pp .
+	$(PP) $(OPT) printer $(REDIR)
+	$(DEL) printer.pp
+
+getopts$(PPUEXT) : $(PROCINC)/getopts.pp system$(PPUEXT)
+	$(COPY) $(PROCINC)/getopts.pp .
+	$(PP) $(OPT) getopts $(REDIR)
+	$(DEL) getopts.pp
+
+graph$(PPUEXT) : ../graph.pp mmx$(PPUEXT) go32$(PPUEXT) system$(PPUEXT) \
+	$(PPI)/arc.ppi $(PPI)/colors.ppi $(PPI)/dpmi2raw.ppi $(PPI)/ellipse.ppi \
+	$(PPI)/fill.ppi $(PPI)/font.ppi $(PPI)/global.ppi $(PPI)/ibm.ppi \
+	$(PPI)/image.ppi $(PPI)/line.ppi $(PPI)/modes.ppi $(PPI)/move.ppi \
+	$(PPI)/palette.ppi $(PPI)/pixel.ppi $(PPI)/stdcolor.ppi $(PPI)/text.ppi \
+	$(PPI)/triangle.ppi $(PPI)/vesadeb.ppi
+	$(COPY) ../graph.pp $(PPI)/*.ppi .
+	$(PP) $(OPT) graph $(REDIR)
+	$(DEL) graph.pp *.ppi
+
+strings$(PPUEXT) : $(PROCINC)/strings.pp system$(PPUEXT)
+	$(COPY) $(PROCINC)/strings.pp .
+	$(PP) $(OPT) strings $(REDIR)
+	$(DEL) strings.pp
+
+dos$(PPUEXT) : ../dos.pp $(INC)/filerec.inc $(INC)/textrec.inc \
+	go32$(PPUEXT) system$(PPUEXT) strings$(PPUEXT)
+	$(COPY) ../dos.pp $(INC)/filerec.inc $(INC)/textrec.inc .
+	$(PP) $(OPT) dos $(REDIR)
+	$(DEL) dos.pp filerec.inc textrec.inc
+
+exceptn$(OEXT) : exceptn.as
+	as -o exceptn$(OEXT) exceptn.as
+#   gcc not need anymore
+#	gcc -c -x assembler-with-cpp -o exceptn$(OEXT) exceptn.AS
+
+dpmiexcp$(PPUEXT) : dpmiexcp.pp exceptn$(OEXT)
+	$(PP) $(OPT) -Sg dpmiexcp $(REDIR)
+
+profile$(PPUEXT) : profile.pp dpmiexcp$(PPUEXT) go32$(PPUEXT)
+	$(PP) $(OPT) profile $(REDIR)
+
+system$(PPUEXT) : system.pp $(SYSTEMDEPS)
+	$(COPY) $(INC)/*.inc $(PROCINC)/*.inc .
+	$(PP) $(OPT) -dI386 -Us -Sg system $(REDIR)
+	$(DEL) systemh.inc system.inc real2str.inc version.inc $(CPU).inc sstrings.inc
+	$(DEL) mathh.inc math.inc set.inc innr.inc heap.inc heaph.inc objpash.inc
+	$(DEL) filerec.inc textrec.inc file.inc typefile.inc text.inc objpas.inc
+
+prt0$(OEXT) : v2prt0.as
+	as -o prt0$(OEXT) v2prt0.as
+#   gcc not need anymore
+#	gcc -c -x assembler-with-cpp -o prt0$(OEXT) v2prt0.AS
+
+crt$(PPUEXT) : ../crt.pp $(INC)/textrec.inc go32$(PPUEXT) system$(PPUEXT)
+	$(COPY) ../crt.pp $(INC)/textrec.inc .
+	$(PP) $(OPT) crt $(REDIR)
+	$(DEL) crt.pp textrec.inc
+
+go32$(PPUEXT) : ../go32.pp system$(PPUEXT)
+	$(COPY) ../go32.pp .
+	$(PP) $(OPT) go32 $(REDIR)
+	$(DEL) go32.pp
+
+mmx$(PPUEXT) : ../../i386/mmx.pp cpu$(PPUEXT) system$(PPUEXT)
+	$(COPY) ../../i386/mmx.pp .
+	$(PP) $(OPT) mmx $(REDIR)
+	$(DEL) mmx.pp
+
+cpu$(PPUEXT) : ../../i386/cpu.pp system$(PPUEXT)
+	$(COPY) ../../i386/cpu.pp .
+	$(PP) $(OPT) cpu $(REDIR)
+	$(DEL) cpu.pp
+
+objpas$(PPUEXT) : ../../objpas/objpas.pp system$(PPUEXT)
+	$(COPY) ../../objpas/objpas.pp .
+	$(PP) $(OPT) objpas $(REDIR)
+	$(DEL) objpas.pp
+
+objects$(PPUEXT) : ../objects.pp system$(PPUEXT)
+	$(COPY) ../objects.pp .
+	$(PP) $(OPT) objects $(REDIR)
+	$(DEL) objects.pp
+
+mouse$(PPUEXT) : ../mouse.pp system$(PPUEXT)
+	$(COPY) ../mouse.pp .
+	$(PP) $(OPT) mouse $(REDIR)
+	$(DEL) mouse.pp
+
+fmouse$(PPUEXT) : ../fmouse.pp system$(PPUEXT)
+	$(COPY) ../fmouse.pp .
+	$(PP) $(OPT) fmouse $(REDIR)
+	$(DEL) fmouse.pp
+
+libs: libfpc$(LIBEXT)
+
+libfpc.a: all
+	$(PPUMOVE) -s -o fpc *.ppu
+
+clean:
+	-$(DEL) *$(OEXT) *$(PPUEXT) *.dif log *.s
+
+diffclean:
+	-$(DEL) *.dif
+
+install: all
+	-$(MKDIR) $(UNITINSTALLDIR)/go32unit
+	$(INSTALL) *$(PPUEXT) $(UNITINSTALLDIR)/go32unit
+	$(INSTALL) *$(OEXT)   $(UNITINSTALLDIR)/go32unit
+
+libinstall: libs
+	$(INSTALL) libfpc$(LIBEXT) $(LIBINSTALLDIR)
+	$(INSTALL) *$(PPLEXT) $(UNITINSTALLDIR)
+
+%.dif : %.pp
+	-$(DIFF) $(DIFFOPTS) $*.pp $(REFPATH)/dos/go32v2/$*.pp > $*.dif
+
+%.dif : %.inc
+	-$(DIFF) $(DIFFOPTS) $*.inc $(REFPATH)/dos/go32v2/$*.inc > $*.dif
+
+# these must have the lowest priority
+
+%.dif : %.as
+	-$(DIFF) $(DIFFOPTS) $*.as $(REFPATH)/dos/go32v2/$*.as > $*.dif
+
+%.dif : %.asm
+	-$(DIFF) $(DIFFOPTS) $*.asm $(REFPATH)/dos/go32v2/$*.asm > $*.dif
+
+makefile.dif : makefile
+	-$(DIFF) $(DIFFOPTS) makefile $(REFPATH)/dos/go32v2/makefile > makefile.dif
+
+diffs: system.dif v2prt0.dif dpmiexcp.dif exceptn.dif profile.dif os.dif \
+       sbrk16.dif exit16.dif makefile.dif

rtl/dos/go32v2/os.inc

@@ -0,0 +1,45 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+{$undef dos}
+{$define go32v2}
+{$undef os2}
+{$undef linux}
+{$undef win32}
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:42  root
+  Initial revision
+
+  Revision 1.3  1998/01/26 11:57:12  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/dos/go32v2/os.inc
+  description:
+  ----------------------------
+  revision 1.2
+  date: 1997/12/01 15:35:00;  author: michael;  state: Exp;  lines: +13 -0
+  + Added copyright reference in header.
+  ----------------------------
+  revision 1.1
+  date: 1997/11/27 08:33:52;  author: michael;  state: Exp;
+  Initial revision
+  ----------------------------
+  revision 1.1.1.1
+  date: 1997/11/27 08:33:52;  author: michael;  state: Exp;  lines: +0 -0
+  FPC RTL CVS start
+  =============================================================================
+}

rtl/dos/go32v2/profile.pp

@@ -0,0 +1,407 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by Pierre Muller,
+    member of the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+
+Unit profile;
+
+{$I os.inc}
+
+interface
+
+uses go32,dpmiexcp;
+
+type header = record
+             low,high,nbytes : longint;
+             end;
+
+{/* entry of a GPROF type file
+*/}
+type MTABE = record
+             from,_to,count : longint;
+             end;
+
+     pMTABE = ^MTABE;
+     ppMTABE = ^pMTABE;
+{/* internal form - sizeof(MTAB) is 4096 for efficiency
+*/ }
+type
+  PMTAB = ^M_TAB;
+  M_TAB  = record
+          calls : array [0..340] of MTABE;
+          prev : PMTAB;
+          end;
+var
+   h : header;
+   histogram : ^integer;
+const
+   mcount_skip : longint = 1;
+var
+   histlen : longint;
+   oldexitproc : pointer;
+
+const
+   mtab : PMTAB = nil;
+
+{/* called by functions.  Use the pointer it provides to cache
+** the last used MTABE, so that repeated calls to/from the same
+** pair works quickly - no lookup.
+*/ }
+procedure mcount;
+
+implementation
+
+type plongint = ^longint;
+
+var starttext, endtext : longint;
+
+const cache : pMTABE = nil;
+
+  { ebp contains the frame of mcount)
+    (ebp) the frame of calling (to_)
+    ((ebp)) the frame of from }
+
+    { problem how to avoid mcount calling itself !! }
+  procedure mcount;  [public, alias : 'MCOUNT'];
+    var
+       m : pmtab;
+       i,to_,ebp,from,mtabi : longint;
+
+    begin
+       { optimisation !! }
+       asm
+          pushal
+          movl 4(%ebp),%eax
+          movl %eax,to_
+          movl (%ebp),%eax
+          movl 4(%eax),%eax
+          movl %eax,from
+       end;
+       if endtext=0 then
+         asm
+            popal
+            leave
+            ret
+         end;
+       mcount_skip := 1;
+       if (to_ > endtext) or (from > endtext) then runerror(255);
+       if ((cache<>nil) and
+         (cache^.from=from) and
+         (cache^._to=to_)) then
+         begin
+       {/* cache paid off - works quickly */}
+       inc(cache^.count);
+       mcount_skip:=0;
+       asm
+          popal
+          leave
+          ret
+       end;
+    end;
+
+  {/* no cache hit - search all mtab tables for a match, or an empty slot */}
+  mtabi := -1;
+  m:=mtab;
+  while m<>nil do
+    begin
+       for i:=0 to 340 do
+         begin
+           if m^.calls[i].from=0 then
+             begin
+                {/* empty slot - end of table */ }
+                mtabi := i;
+                break;
+             end;
+           if ((m^.calls[i].from = from) and
+               (m^.calls[i]._to = to_)) then
+             begin
+                {/* found a match - bump count and return */}
+                inc(m^.calls[i].count);
+                cache:=@(m^.calls[i]);
+                mcount_skip:=0;
+                asm
+                   popal
+                   leave
+                   ret
+                end;
+             end;
+        end;
+      m:=m^.prev;
+   end;
+  if (mtabi<>-1) then
+    begin
+       {/* found an empty - fill it in */}
+       mtab^.calls[mtabi].from := from;
+       mtab^.calls[mtabi]._to := to_;
+       mtab^.calls[mtabi].count := 1;
+       cache := @(mtab^.calls[mtabi]);
+       mcount_skip := 0;
+       asm
+          popal
+          leave
+          ret
+       end;
+    end;
+  {/* lob off another page of memory and initialize the new table */}
+  getmem(m,sizeof(M_TAB));
+  fillchar(m^, sizeof(M_TAB),#0);
+  m^.prev := mtab;
+  mtab := m;
+  m^.calls[0].from := from;
+  m^.calls[0]._to := to_;
+  m^.calls[0].count := 1;
+  cache := @(m^.calls[0]);
+  mcount_skip := 0;
+  asm
+     popal
+     leave
+     ret
+  end;
+  end;
+
+  var new_timer,old_timer : tseginfo;
+
+{ from itimer.c
+/* Copyright (C) 1995 Charles Sandmann ([email protected])
+   setitimer implmentation - used for profiling and alarm
+   BUGS: ONLY ONE AT A TIME, first pass code
+   This software may be freely distributed, no warranty. */ }
+
+{ static void timer_action(int signum) }
+{
+  if(reload)
+    __djgpp_timer_countdown = reload;
+  else
+    stop_timer();
+  raise(sigtype);
+}
+var reload : longint;
+const invalid_mcount_call : longint = 0;
+      mcount_nb : longint = 0;
+      doublecall : longint = 0;
+
+function mcount_tick(x : longint) : longint;forward;
+
+function timer(x : longint) : longint;
+begin
+   if reload>0 then
+     asm
+       movl _RELOAD,%eax
+       movl %eax,___djgpp_timer_countdown
+     end;
+
+   mcount_tick(x);
+   { _raise(SIGPROF); }
+end;
+
+{/* this is called during program exit (installed by atexit). */}
+procedure mcount_write;
+ var m : PMTAB;
+     i : longint;
+     f : file;
+{
+  MTAB *m;
+  int i, f;
+  struct itimerval new_values;
+
+  mcount_skip = 1;
+
+  /* disable timer */
+  new_values.it_value.tv_usec = new_values.it_interval.tv_usec = 0;
+  new_values.it_value.tv_sec = new_values.it_interval.tv_sec = 0;
+  setitimer(ITIMER_PROF, &new_values, NULL); }
+  begin
+  mcount_skip:=1;
+  signal(SIGTIMR,@SIG_IGN);
+  signal(SIGPROF,@SIG_IGN);
+  set_pm_interrupt($8,old_timer);
+  reload:=0;
+  exitproc:=oldexitproc;
+  writeln('Writing profile output');
+  writeln('histogram length = ',histlen);
+  writeln('Nb of double calls = ',doublecall);
+  if invalid_mcount_call>0 then
+    writeln('nb of invalid mcount : ',invalid_mcount_call,'/',mcount_nb)
+  else
+    writeln('nb of mcount : ',mcount_nb);
+  assign(f,'gmon.out');
+  rewrite(f,1);
+  blockwrite(f, h, sizeof(header));
+  blockwrite(f, histogram^, histlen);
+  m:=mtab;
+  while m<>nil do
+    begin
+       for i:=0 to 340 do
+         begin
+            if (m^.calls[i].from = 0) then
+              break;
+            blockwrite(f, m^.calls[i],sizeof(MTABE));
+{$ifdef DEBUG}
+            if m^.calls[i].count>0 then
+              writeln('  0x',hexstr(m^.calls[i]._to,8),' called from ',hexstr(m^.calls[i].from,8),
+                ' ',m^.calls[i].count,' times');
+{$endif DEBUG}
+         end;
+       m:=m^.prev;
+    end;
+  close(f);
+end;
+
+(* extern unsigned start __asm__ ("start");
+#define START (unsigned)&start
+extern int etext;
+
+/* ARGSUSED */
+static void *)
+
+
+function mcount_tick(x : longint) : longint;
+  var bin : longint;
+begin
+   if mcount_skip=0 then
+     begin
+        {bin = __djgpp_exception_state->__eip;}
+        bin := djgpp_exception_state^.__eip;
+        if (djgpp_exception_state^.__cs=get_cs) and
+           (bin >= starttext) and (bin <= endtext) then
+          begin
+             {bin := (bin - starttext) div 4;}	{/* 4 EIP's per bin */}
+             bin := (bin - starttext) div 16;
+             inc(histogram[bin]);
+          end
+        else
+          inc(invalid_mcount_call);
+        inc(mcount_nb);
+     end
+   else
+     inc(doublecall);
+   mcount_tick:=0;
+end;
+
+{/* this is called to initialize profiling before the program starts */}
+procedure _mcount_init;
+
+{struct itimerval new_values;}
+
+  function djgpp_timer_hdlr : pointer;
+    begin
+       asm
+          movl $___djgpp_timer_hdlr,%eax
+          movl %eax,__RESULT
+       end;
+    end;
+
+  procedure set_old_timer_handler;
+    begin
+       asm
+          movl $_OLD_TIMER,%eax
+          movl $___djgpp_old_timer,%ebx
+          movl (%eax),%ecx
+          movl %ecx,(%ebx)
+          movw 4(%eax),%ax
+          movw %ax,4(%ebx)
+       end;
+
+    end;
+begin
+
+       asm
+          movl $_etext,_ENDTEXT
+          movl $start,_STARTTEXT
+       end;
+  h.low := starttext;
+  h.high := endtext;
+  histlen := ((h.high-h.low) div 16) * 2; { must be even }
+  h.nbytes := sizeof(header) + histlen;
+  getmem(histogram,histlen);
+  fillchar(histogram^, histlen,#0);
+
+  oldexitproc:=exitproc;
+  exitproc:=@mcount_write;
+
+  {/* here, do whatever it takes to initialize the timer interrupt */}
+  signal(SIGPROF,@mcount_tick);
+  signal(SIGTIMR,@timer);
+
+  get_pm_interrupt($8,old_timer);
+  set_old_timer_handler;
+{$ifdef DEBUG}
+       writeln(stderr,'ori pm int8  '+hexstr(old_timer.segment,4)+':'
+           +hexstr(longint(old_timer.offset),8));
+       flush(stderr);
+{$endif DEBUG}
+  new_timer.segment:=get_cs;
+  new_timer.offset:=djgpp_timer_hdlr;
+  reload:=3;
+{$ifdef DEBUG}
+       writeln(stderr,'new pm int8  '+hexstr(new_timer.segment,4)+':'
+           +hexstr(longint(new_timer.offset),8));
+       flush(stderr);
+{$endif DEBUG}
+  set_pm_interrupt($8,new_timer);
+  reload:=1;
+     asm
+       movl _RELOAD,%eax
+       movl %eax,___djgpp_timer_countdown
+     end;
+  mcount_skip := 0;
+  end;
+
+begin
+_mcount_init;
+end.
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:42  root
+  Initial revision
+
+  Revision 1.4  1998/01/26 11:57:39  michael
+  + Added log at the end
+
+  Revision 1.3  1998/01/16 16:54:22  pierre
+    + logs added at end
+    + dxeload and emu387 added in makefile
+
+}
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:42  root
+  Initial revision
+
+  Revision 1.4  1998/01/26 11:57:39  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/dos/go32v2/profile.pp
+  description:
+  ----------------------------
+  revision 1.3
+  date: 1998/01/16 16:54:22;  author: pierre;  state: Exp;  lines: +5 -2
+    + logs added at end
+    + dxeload and emu387 added in makefile
+  ----------------------------
+  revision 1.2
+  date: 1997/12/01 12:26:09;  author: michael;  state: Exp;  lines: +14 -3
+  + added copyright reference in header.
+  ----------------------------
+  revision 1.1
+  date: 1997/11/27 08:33:52;  author: michael;  state: Exp;
+  Initial revision
+  ----------------------------
+  revision 1.1.1.1
+  date: 1997/11/27 08:33:52;  author: michael;  state: Exp;  lines: +0 -0
+  FPC RTL CVS start
+  =============================================================================
+}

rtl/dos/go32v2/sargs.inc

@@ -0,0 +1,240 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by Pierre Muller,
+    member of the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    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.
+
+ **********************************************************************}
+
+var argc : longint;
+    doscmd : string;
+    args : ^pchar;
+
+function far_strlen(selector : word;linear_address : longint) : longint;
+begin
+asm
+	movl linear_address,%edx
+	movl %edx,%ecx
+	movw selector,%gs
+Larg19:
+	movb %gs:(%edx),%al
+	testb %al,%al
+	je Larg20
+	incl %edx
+	jmp Larg19
+Larg20:
+	movl %edx,%eax
+	subl %ecx,%eax
+        movl %eax,__RESULT
+end;
+end;
+
+function atohex(s : pchar) : longint;
+var rv : longint;
+    v : byte;
+begin
+rv := 0;
+while (s^ <>#0) do
+  begin
+  v := ord(s^) - ord('0');
+  if (v > 9) then v := v - 7;
+  v := v and 15; { in case it's lower case }
+  rv := rv*16 + v;
+  inc(longint(s));
+  end;
+atohex := rv;
+end;
+
+procedure setup_arguments;
+type  arrayword = array [0..0] of word;
+var psp : word;
+    i,j : byte;
+    quote : char;
+    proxy_s : string[7];
+    al,proxy_argc,proxy_seg,proxy_ofs,lin : longint;
+    largs : array[0..127] of pchar;
+    rm_argv : ^arrayword;
+begin
+for i := 1 to 127  do
+   largs[i] := nil;
+psp:=stub_info^.psp_selector;
+largs[0]:=dos_argv0;
+argc := 1;
+sysseg_move(psp, 128, get_ds, longint(@doscmd), 128);
+{$IfDef SYSTEMDEBUG}
+Writeln('Dos command line is #',doscmd,'# size = ',length(doscmd));
+{$EndIf SYSTEMDEBUG}
+j := 1;
+quote := #0;
+for i:=1 to length(doscmd) do
+  Begin
+  if doscmd[i] = quote then
+    begin
+    quote := #0;
+    doscmd[i] := #0;
+    largs[argc]:=@doscmd[j];
+    inc(argc);
+    j := i+1;
+    end else
+  if (quote = #0) and ((doscmd[i] = '''') or (doscmd[i]='"')) then
+    begin
+    quote := doscmd[i];
+    j := i + 1;
+    end else
+  if (quote = #0) and ((doscmd[i] = ' ')
+    or (doscmd[i] = #9) or (doscmd[i] = #10) or
+    (doscmd[i] = #12) or (doscmd[i] = #9)) then
+    begin
+    doscmd[i]:=#0;
+    if j<i then
+      begin
+      largs[argc]:=@doscmd[j];
+      inc(argc);
+      j := i+1;
+      end else inc(j);
+    end else
+  if (i = length(doscmd)) then
+    begin
+    doscmd[i+1]:=#0;
+    largs[argc]:=@doscmd[j];
+    inc(argc);
+    end;
+  end;
+
+if (argc > 1) and (far_strlen(get_ds,longint(largs[1])) = 6)  then
+  begin
+  move(largs[1]^,proxy_s[1],6);
+  proxy_s[0] := #6;
+  if (proxy_s = '!proxy') then
+    begin
+{$IfDef SYSTEMDEBUG}
+    Writeln('proxy command line ');
+{$EndIf SYSTEMDEBUG}
+    proxy_argc := atohex(largs[2]);
+    proxy_seg  := atohex(largs[3]);
+    proxy_ofs := atohex(largs[4]);
+    getmem(rm_argv,proxy_argc*sizeof(word));
+    sysseg_move(dos_selector,proxy_seg*16+proxy_ofs, get_ds,longint(rm_argv),proxy_argc*sizeof(word));
+    for i:=0 to proxy_argc - 1 do
+      begin
+      lin := proxy_seg*16 + rm_argv^[i];
+      al :=far_strlen(dos_selector, lin);
+      getmem(largs[i],al+1);
+      sysseg_move(dos_selector, lin, get_ds,longint(largs[i]), al+1);
+{$IfDef SYSTEMDEBUG}
+      Writeln('arg ',i,' #',largs[i],'#');
+{$EndIf SYSTEMDEBUG}
+      end;
+    argc := proxy_argc;
+    end;
+  end;
+getmem(args,argc*SizeOf(pchar));
+for i := 0 to argc-1  do
+   args[i] := largs[i];
+end;
+
+function strcopy(dest,source : pchar) : pchar;
+    
+      begin
+         asm
+            cld
+            movl 12(%ebp),%edi
+            movl $0xffffffff,%ecx
+            xorb %al,%al
+            repne
+            scasb
+            not %ecx
+            movl 8(%ebp),%edi
+            movl 12(%ebp),%esi
+            movl %ecx,%eax
+            shrl $2,%ecx
+            rep
+            movsl
+            movl %eax,%ecx
+            andl $3,%ecx
+            rep
+            movsb
+            movl 8(%ebp),%eax
+            leave
+            ret $8
+         end;
+      end;
+
+
+procedure setup_environment;
+var env_selector : word;
+    env_count : longint;
+    dos_env,cp : pchar;
+    stubaddr : p_stub_info;
+begin
+   asm
+   movl __stubinfo,%eax
+   movl %eax,stubaddr
+   end;
+   stub_info:=stubaddr;
+   getmem(dos_env,stub_info^.env_size);
+   env_count:=0;
+   sysseg_move(stub_info^.psp_selector,$2c, get_ds, longint(@env_selector), 2);
+   sysseg_move(env_selector, 0, get_ds, longint(dos_env), stub_info^.env_size);
+  cp:=dos_env;
+  while cp ^ <> #0 do
+    begin
+    inc(env_count);
+    while (cp^ <> #0) do inc(longint(cp)); { skip to NUL }
+    inc(longint(cp)); { skip to next character }
+    end;
+  getmem(environ,(env_count+1) * sizeof(pchar));
+  if (environ = nil) then exit;
+  cp:=dos_env;
+  env_count:=0;
+  while cp^ <> #0 do
+    begin
+    getmem(environ[env_count],strlen(cp)+1);
+    strcopy(environ[env_count], cp);
+{$IfDef SYSTEMDEBUG}
+      Writeln('env ',env_count,' = "',environ[env_count],'"');
+{$EndIf SYSTEMDEBUG}
+    inc(env_count);
+    while (cp^ <> #0) do inc(longint(cp)); { skip to NUL }
+    inc(longint(cp)); { skip to next character }
+    end;
+  environ[env_count]:=nil;
+  inc(longint(cp),3);
+  getmem(dos_argv0,strlen(cp)+1);
+  if (dos_argv0 = nil) then halt;
+  strcopy(dos_argv0, cp);
+end;
+
+{
+  $Log$
+  Revision 1.1  1998-03-25 11:18:42  root
+  Initial revision
+
+  Revision 1.3  1998/01/26 11:57:15  michael
+  + Added log at the end
+
+
+  
+  Working file: rtl/dos/go32v2/sargs.inc
+  description:
+  ----------------------------
+  revision 1.2
+  date: 1997/12/01 15:35:01;  author: michael;  state: Exp;  lines: +14 -0
+  + Added copyright reference in header.
+  ----------------------------
+  revision 1.1
+  date: 1997/11/27 08:33:52;  author: michael;  state: Exp;
+  Initial revision
+  ----------------------------
+  revision 1.1.1.1
+  date: 1997/11/27 08:33:52;  author: michael;  state: Exp;  lines: +0 -0
+  FPC RTL CVS start
+  =============================================================================
+}