home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / compiler / cga68k.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-09-24  |  57.1 KB  |  1,430 lines
  1. {
  2.     $Id: cga68k.pas,v 1.2.2.7 1998/08/14 12:04:36 carl Exp $
  3.     Copyright (c) 1993-98 by Florian Klaempfl, Carl Eric Codere
  4.  
  5.     This unit generates 68000 (or better) assembler from the parse tree
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23. unit cga68k;
  24.  
  25.   interface
  26.  
  27.     uses
  28.        objects,cobjects,verbose,systems,globals,tree,symtable,types,strings,
  29.        pass_1,hcodegen,aasm,m68k,tgen68k,files,gdb;
  30.  
  31.     procedure emitl(op : tasmop;var l : plabel);
  32.     procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister);
  33.     procedure emitcall(const routine:string;add_to_externals : boolean);
  34.     procedure emitloadord2reg(location:Tlocation;orddef:Porddef;
  35.                               destreg:Tregister;delloc:boolean);
  36.     { produces jumps to true respectively false labels using boolean expressions }
  37.     procedure maketojumpbool(p : ptree);
  38.     procedure emitoverflowcheck(p: ptree);
  39.     procedure push_int(l : longint);
  40.     function maybe_push(needed : byte;p : ptree) : boolean;
  41.     procedure restore(p : ptree);
  42.     procedure emit_push_mem(const ref : treference);
  43.     procedure emitpushreferenceaddr(const ref : treference);
  44.     procedure swaptree(p: ptree);
  45.     procedure copystring(const dref,sref : treference;len : byte);
  46.     procedure concatcopy(source,dest : treference;size : longint;delsource : boolean);
  47.     { see implementation }
  48.     procedure maybe_loada5;
  49.     procedure emit_bounds_check(hp: treference; index: tregister);
  50.     procedure loadstring(p:ptree);
  51.  
  52.     procedure floatload(t : tfloattype;const ref : treference; var location:tlocation);
  53.     { return a float op_size from a floatb type  }
  54.     { also does some error checking for problems }
  55.     function getfloatsize(t: tfloattype): topsize;
  56.     procedure floatstore(t : tfloattype;var location:tlocation; const ref:treference);
  57. {    procedure floatloadops(t : tfloattype;var op : tasmop;var s : topsize);
  58.     procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize); }
  59.  
  60.     procedure firstcomplex(p : ptree);
  61.     procedure secondfuncret(var p : ptree);
  62.  
  63.     { initialize respectively terminates the code generator }
  64.     { for a new module or procedure                         }
  65.     procedure codegen_doneprocedure;
  66.     procedure codegen_donemodule;
  67.     procedure codegen_newmodule;
  68.     procedure codegen_newprocedure;
  69.  
  70.     { generate entry code for a procedure.}
  71.     procedure genentrycode(const proc_names:Tstringcontainer;make_global:boolean;
  72.                            stackframe:longint;
  73.                            var parasize:longint;var nostackframe:boolean);
  74.     { generate the exit code for a procedure. }
  75.     procedure genexitcode(parasize:longint;nostackframe:boolean);
  76.  
  77.  
  78.   implementation
  79.  
  80.     {
  81.     procedure genconstadd(size : topsize;l : longint;const str : string);
  82.  
  83.       begin
  84.          if l=0 then
  85.          else if l=1 then
  86.            exprasmlist^.concat(new(pai68k,op_A_INC,size,str)
  87.          else if l=-1 then
  88.            exprasmlist^.concat(new(pai68k,op_A_INC,size,str)
  89.          else
  90.            exprasmlist^.concat(new(pai68k,op_ADD,size,'$'+tostr(l)+','+str);
  91.       end;
  92.     }
  93.     procedure copystring(const dref,sref : treference;len : byte);
  94.  
  95.       var
  96.          pushed : tpushed;
  97.  
  98.       begin
  99.          pushusedregisters(pushed,$ffff);
  100. {         emitpushreferenceaddr(dref);       }
  101. {         emitpushreferenceaddr(sref);       }
  102. {         push_int(len);                     }
  103.          { This speeds up from 116 cycles to 24 cycles on the 68000 }
  104.          { when passing register parameters!                        }
  105.          exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(dref),R_A1)));
  106.          exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(sref),R_A0)));
  107.          exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,len,R_D0)));
  108.          emitcall('STRCOPY',true);
  109.          maybe_loada5;
  110.          popusedregisters(pushed);
  111.       end;
  112.  
  113.  
  114.     procedure loadstring(p:ptree);
  115.       begin
  116.         case p^.right^.resulttype^.deftype of
  117.          stringdef : begin
  118.                        { load a string ... }
  119.                        { here two possible choices:      }
  120.                        { if it is a char, then simply    }
  121.                        { load 0 length string            }
  122.                        if (p^.right^.treetype=stringconstn) and
  123.                           (p^.right^.values^='') then
  124.                         exprasmlist^.concat(new(pai68k,op_const_ref(
  125.                            A_MOVE,S_B,0,newreference(p^.left^.location.reference))))
  126.                        else
  127.                         copystring(p^.left^.location.reference,p^.right^.location.reference,
  128.                            min(pstringdef(p^.right^.resulttype)^.len,pstringdef(p^.left^.resulttype)^.len));
  129.                      end;
  130.             orddef : begin
  131.                        if p^.right^.treetype=ordconstn then
  132.                         begin
  133.                             { offset 0: length of string }
  134.                             { offset 1: character        }
  135.                             exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_W,1*256+p^.right^.value,
  136.                               newreference(p^.left^.location.reference))))
  137.                         end
  138.                        else
  139.                          begin
  140.                             { not so elegant (goes better with extra register }
  141.                             if (p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
  142.                               begin
  143.                                  exprasmlist^.concat(new(pai68k,op_reg_reg(
  144.                                     A_MOVE,S_B,p^.right^.location.register,R_D0)));
  145.                                  ungetregister32(p^.right^.location.register);
  146.                               end
  147.                             else
  148.                               begin
  149.                                  exprasmlist^.concat(new(pai68k,op_ref_reg(
  150.                                     A_MOVE,S_B,newreference(p^.right^.location.reference),R_D0)));
  151.                                  del_reference(p^.right^.location.reference);
  152.                               end;
  153.                             { alignment can cause problems }
  154.                             { add length of string to ref }
  155.                             exprasmlist^.concat(new(pai68k,op_const_ref(A_MOVE,S_B,1,
  156.                                newreference(p^.left^.location.reference))));
  157. (*                            if abs(p^.left^.location.reference.offset) >= 1 then
  158.                               Begin *)
  159.                               { temporarily decrease offset }
  160.                                 Inc(p^.left^.location.reference.offset);
  161.                                  exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_B,R_D0,
  162.                                   newreference(p^.left^.location.reference))));
  163.                                 Dec(p^.left^.location.reference.offset);
  164.                                 { restore offset }
  165. (*                              end
  166.                             else
  167.                               Begin
  168.                                 Comment(V_Debug,'SecondChar2String() internal error.');
  169.                                 internalerror(34);
  170.                               end; *)
  171.                          end;
  172.                        end;
  173.         else
  174.          Message(sym_e_type_mismatch);
  175.         end;
  176.       end;
  177.  
  178.  
  179.  
  180.  
  181.  
  182.     procedure restore(p : ptree);
  183.  
  184.       var
  185.          hregister :  tregister;
  186.  
  187.       begin
  188.          if (p^.location.loc=LOC_REGISTER) or (p^.location.loc=LOC_CREGISTER) then
  189.             hregister:=getregister32
  190.          else
  191.             hregister:=getaddressreg;
  192.  
  193.          exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_SPPULL,hregister)));
  194.          if (p^.location.loc=LOC_REGISTER) or (p^.location.loc=LOC_CREGISTER) then
  195.            begin
  196.               p^.location.register:=hregister;
  197.            end
  198.          else
  199.            begin
  200.               reset_reference(p^.location.reference);
  201.               p^.location.reference.base:=hregister;
  202.               set_location(p^.left^.location,p^.location);
  203.            end;
  204.       end;
  205.  
  206.     function maybe_push(needed : byte;p : ptree) : boolean;
  207.  
  208.       var
  209.          pushed : boolean;
  210.          {hregister : tregister; }
  211.          reg: tregister;
  212.       begin
  213.          if (needed>usablereg32) or (needed > usableaddress) then
  214.            begin
  215.               if (p^.location.loc=LOC_REGISTER) or
  216.                  (p^.location.loc=LOC_CREGISTER) then
  217.                 begin
  218.                    pushed:=true;
  219.                    exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,p^.location.register,R_SPPUSH)));
  220.                    ungetregister32(p^.location.register);
  221.                 end
  222.                else
  223.                  if ((p^.location.loc=LOC_MEM) or(p^.location.loc=LOC_REFERENCE)) and
  224.                     ((p^.location.reference.base<>R_NO) or
  225.                     (p^.location.reference.index<>R_NO)) then
  226.                   begin
  227.                      del_reference(p^.location.reference);
  228.                      exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(p^.location.reference),
  229.                         R_A0)));
  230.                      exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A0,R_SPPUSH)));
  231.                      pushed:=true;
  232.                   end
  233.               else pushed:=false;
  234.            end
  235.          else pushed:=false;
  236.          maybe_push:=pushed;
  237.       end;
  238.  
  239.  
  240.     { emit out of range check for arrays and sets}
  241.     procedure emit_bounds_check(hp: treference; index: tregister);
  242.     { index = index of array to check }
  243.     { memory of range check information for array }
  244.      var
  245.       hl : plabel;
  246.      begin
  247.         if (opt_processors = MC68020) then
  248.           begin
  249.              exprasmlist^.concat(new(pai68k, op_ref_reg(A_CMP2,S_L,newreference(hp),index)));
  250.              getlabel(hl);
  251.              emitl(A_BCC, hl);
  252.              exprasmlist^.concat(new(pai68k, op_const_reg(A_MOVE,S_L,201,R_D0)));
  253.              emitcall('HALT_ERROR',true);
  254.              emitl(A_LABEL, hl);
  255.           end
  256.         else
  257.           begin
  258.             exprasmlist^.concat(new(pai68k, op_ref_reg(A_LEA,S_L,newreference(hp), R_A1)));
  259.             exprasmlist^.concat(new(pai68k, op_reg_reg(A_MOVE, S_L, index, R_D0)));
  260.             emitcall('RE_BOUNDS_CHECK',true);
  261.           end;
  262.      end;
  263.  
  264.  
  265.  
  266.     function getfloatsize(t: tfloattype): topsize;
  267.     begin
  268.       case t of
  269.       s32real: getfloatsize := S_S;
  270.       s64real: getfloatsize := S_Q;
  271.       s80real: getfloatsize := S_X;
  272. {$ifdef extdebug}
  273.     else {else case }
  274.       begin
  275.         Comment(V_Debug,' getfloatsize() trying to get unknown size.');
  276.         internalerror(12);
  277.       end;
  278. {$endif}
  279.      end;
  280.     end;
  281.  
  282.     procedure emitl(op : tasmop;var l : plabel);
  283.  
  284.       begin
  285.          if op=A_LABEL then
  286.            exprasmlist^.concat(new(pai_label,init(l)))
  287.          else
  288.            exprasmlist^.concat(new(pai_labeled,init(op,l)))
  289.       end;
  290.  
  291.     procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister);
  292.  
  293.       begin
  294.          if (reg1 <> reg2) or (i <> A_MOVE) then
  295.            exprasmlist^.concat(new(pai68k,op_reg_reg(i,s,reg1,reg2)));
  296.       end;
  297.  
  298.  
  299.     procedure emitcall(const routine:string;add_to_externals : boolean);
  300.  
  301.      begin
  302.         exprasmlist^.concat(new(pai68k,op_csymbol(A_JSR,S_NO,newcsymbol(routine,0))));
  303.         if assem_need_external_list and add_to_externals and
  304.            not (cs_compilesystem in aktswitches) then
  305.           concat_external(routine,EXT_NEAR);
  306.      end;
  307.  
  308.  
  309.     procedure maketojumpbool(p : ptree);
  310.  
  311.       begin
  312.          if p^.error then
  313.            exit;
  314.          if (p^.resulttype^.deftype=orddef) and
  315.             (porddef(p^.resulttype)^.typ=bool8bit) then
  316.            begin
  317.               if is_constboolnode(p) then
  318.                 begin
  319.                    if p^.value<>0 then
  320.                      emitl(A_JMP,truelabel)
  321.                    else emitl(A_JMP,falselabel);
  322.                 end
  323.               else
  324.                 begin
  325.                    case p^.location.loc of
  326.                       LOC_CREGISTER,LOC_REGISTER : begin
  327.                                         exprasmlist^.concat(new(pai68k,op_reg(A_TST,S_B,p^.location.register)));
  328.                                         ungetregister32(p^.location.register);
  329.                                         emitl(A_BNE,truelabel);
  330.                                         emitl(A_JMP,falselabel);
  331.                                      end;
  332.                       LOC_MEM,LOC_REFERENCE : begin
  333.                                         exprasmlist^.concat(new(pai68k,op_ref(
  334.                                           A_TST,S_B,newreference(p^.location.reference))));
  335.                                         del_reference(p^.location.reference);
  336.                                         emitl(A_BNE,truelabel);
  337.                                         emitl(A_JMP,falselabel);
  338.                                      end;
  339.                       LOC_FLAGS : begin
  340.                                      emitl(flag_2_jmp[p^.location.resflags],truelabel);
  341.                                      emitl(A_JMP,falselabel);
  342.                                   end;
  343.                    end;
  344.                 end;
  345.            end
  346.          else
  347.           Message(sym_e_type_mismatch);
  348.       end;
  349.  
  350.     procedure emitoverflowcheck(p: ptree);
  351.  
  352.       var
  353.          hl : plabel;
  354.  
  355.       begin
  356.          if cs_check_overflow in aktswitches  then
  357.            begin
  358.               getlabel(hl);
  359.               if not ((p^.resulttype^.deftype=pointerdef) or
  360.                      ((p^.resulttype^.deftype=orddef) and
  361.                 (porddef(p^.resulttype)^.typ in [u16bit,u32bit,u8bit,uchar,bool8bit]))) then
  362.                 emitl(A_BVC,hl)
  363.               else
  364.                 emitl(A_BCC,hl);
  365.               emitcall('RE_OVERFLOW',true);
  366.               emitl(A_LABEL,hl);
  367.            end;
  368.       end;
  369.  
  370.  
  371.     procedure push_int(l : longint);
  372.  
  373.       begin
  374.          if (l = 0) and (opt_processors = MC68020) then
  375.            begin
  376.           exprasmlist^.concat(new(pai68k,op_reg(A_CLR,S_L,R_D6)));
  377.               exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
  378.               R_D6, R_SPPUSH)));
  379.            end
  380.          else
  381.          if not(cs_littlesize in aktswitches) and (l >= -128) and (l <= 127) then
  382.            begin
  383.            exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVEQ,S_L,l,R_D6)));
  384.            exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_D6,R_SPPUSH)));
  385.            end
  386.          else
  387.            exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,l,R_SPPUSH)));
  388.       end;
  389.  
  390.     procedure emit_push_mem(const ref : treference);
  391.     { Push a value on to the stack }
  392.       begin
  393.          if ref.isintvalue then
  394.            push_int(ref.offset)
  395.          else
  396.            exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(ref),R_SPPUSH)));
  397.       end;
  398.  
  399.  
  400.     { USES REGISTER R_A1 }
  401.     procedure emitpushreferenceaddr(const ref : treference);
  402.     { Push a pointer to a value on the stack }
  403.       begin
  404.          if ref.isintvalue then
  405.            push_int(ref.offset)
  406.          else
  407.            begin
  408.               if (ref.base=R_NO) and (ref.index=R_NO) then
  409.                 exprasmlist^.concat(new(pai68k,op_ref(A_PEA,S_L,
  410.                     newreference(ref))))
  411.               else if (ref.base=R_NO) and (ref.index<>R_NO) and
  412.                  (ref.offset=0) and (ref.scalefactor=0) and (ref.symbol=nil) then
  413.                 exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,
  414.                     ref.index,R_SPPUSH)))
  415.               else if (ref.base<>R_NO) and (ref.index=R_NO) and
  416.                  (ref.offset=0) and (ref.symbol=nil) then
  417.                 exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,ref.base,R_SPPUSH)))
  418.               else
  419.                 begin
  420.                    exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(ref),R_A1)));
  421.                    exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A1,R_SPPUSH)));
  422.                 end;
  423.            end;
  424.         end;
  425.  
  426.     procedure swaptree(p:Ptree);
  427.  
  428.     var swapp:Ptree;
  429.  
  430.     begin
  431.         swapp:=p^.right;
  432.         p^.right:=p^.left;
  433.         p^.left:=swapp;
  434.         p^.swaped:=not(p^.swaped);
  435.     end;
  436.  
  437.  
  438. procedure genentrycode(const proc_names:Tstringcontainer;make_global:boolean;
  439.                        stackframe:longint;
  440.                        var parasize:longint;var nostackframe:boolean);
  441.  
  442. {Generates the entry code for a procedure.}
  443.  
  444. var hs:string;
  445.     hp:Pused_unit;
  446.     unitinits:taasmoutput;
  447. {$ifdef GDB}
  448.     oldaktprocname : string;
  449.     stab_function_name:Pai_stab_function_name;
  450. {$endif GDB}
  451. begin
  452.     if (aktprocsym^.definition^.options and poproginit<>0) then
  453.         begin
  454.             {Init the stack checking.}
  455.             if (cs_check_stack in aktswitches) and
  456.              (target_info.target=target_linux) then
  457.                 begin
  458.                     procinfo.aktentrycode^.insert(new(pai68k,
  459.                      op_csymbol(A_JSR,S_NO,newcsymbol('INIT_STACK_CHECK',0))));
  460.                 end
  461.             else
  462.             { The main program has already allocated its stack - so we simply compare }
  463.             { with a value of ZERO, and the comparison will directly check!           }
  464.             if (cs_check_stack in aktswitches) then
  465.                 begin
  466.                   procinfo.aktentrycode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO,
  467.                       newcsymbol('STACKCHECK',0))));
  468.                   procinfo.aktentrycode^.insert(new(pai68k,op_const_reg(A_MOVE,S_L,
  469.                       0,R_D0)));
  470.                   concat_external('STACKCHECK',EXT_NEAR);
  471.                 end;
  472.  
  473.  
  474.             unitinits.init;
  475.  
  476.             {Call the unit init procedures.}
  477.             hp:=pused_unit(usedunits.first);
  478.             while assigned(hp) do
  479.                 begin
  480.                     { call the unit init code and make it external }
  481.                     if (hp^.u^.flags and uf_init)<>0 then
  482.                         begin
  483.                            unitinits.concat(new(pai68k,op_csymbol(A_JSR,S_NO,newcsymbol('INIT$$'+hp^.u^.unitname^,0))));
  484.                            externals^.concat(new(pai_external,init('INIT$$'+hp^.u^.unitname^,EXT_NEAR)));
  485.                         end;
  486.                    hp:=pused_unit(hp^.next);
  487.                 end;
  488.               procinfo.aktentrycode^.insertlist(@unitinits);
  489.               unitinits.done;
  490.         end;
  491.  
  492.         { a constructor needs a help procedure }
  493.         if (aktprocsym^.definition^.options and poconstructor)<>0 then
  494.         begin
  495.            if procinfo._class^.isclass then
  496.              begin
  497.               procinfo.aktentrycode^.insert(new(pai_labeled,init(A_BEQ,quickexitlabel)));
  498.               procinfo.aktentrycode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO,
  499.               newcsymbol('NEW_CLASS',0))));
  500.               concat_external('NEW_CLASS',EXT_NEAR);
  501.              end
  502.            else
  503.              begin
  504.               procinfo.aktentrycode^.insert(new(pai_labeled,init(A_BEQ,quickexitlabel)));
  505.               procinfo.aktentrycode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO,
  506.               newcsymbol('HELP_CONSTRUCTOR',0))));
  507.               concat_external('HELP_CONSTRUCTOR',EXT_NEAR);
  508.              end;
  509.         end;
  510.     { don't load ESI, does the caller }
  511.  
  512.     { omit stack frame ? }
  513.     if procinfo.framepointer=stack_pointer then
  514.         begin
  515.             Message(cg_d_stackframe_omited);
  516.             nostackframe:=true;
  517.             if (aktprocsym^.definition^.options and (pounitinit or poproginit)<>0) then
  518.                 parasize:=0
  519.             else
  520.                 parasize:=aktprocsym^.definition^.parast^.datasize+procinfo.call_offset;
  521.         end
  522.     else
  523.         begin
  524.              if (aktprocsym^.definition^.options and (pounitinit or poproginit)<>0) then
  525.                 parasize:=0
  526.              else
  527.                 parasize:=aktprocsym^.definition^.parast^.datasize+procinfo.call_offset-8;
  528.             nostackframe:=false;
  529.             if stackframe<>0 then
  530.                 begin
  531.                     if cs_littlesize in aktswitches  then
  532.                         begin
  533.                             if (cs_check_stack in aktswitches) and
  534.                              (target_info.target<>target_linux) then
  535.                                 begin
  536.                                   { If only not in main program, do we setup stack checking }
  537.                                   if (aktprocsym^.definition^.options and poproginit=0) then
  538.                                    Begin
  539.                                        procinfo.aktentrycode^.insert(new(pai68k,
  540.                                          op_csymbol(A_JSR,S_NO,newcsymbol('STACKCHECK',0))));
  541.                                        procinfo.aktentrycode^.insert(new(pai68k,op_const_reg(A_MOVE,S_L,stackframe,R_D0)));
  542.                                        concat_external('STACKCHECK',EXT_NEAR);
  543.                                    end;
  544.                                 end;
  545.                             { to allocate stack space }
  546.                             { here we allocate space using link signed 16-bit version }
  547.                             { -ve offset to allocate stack space! }
  548.                             if (stackframe > -32767) and (stackframe < 32769) then
  549.                               procinfo.aktentrycode^.insert(new(pai68k,op_reg_const(A_LINK,S_W,R_A6,-stackframe)))
  550.                             else
  551.                               Message(cg_e_stacklimit_in_local_routine);
  552.                         end
  553.                     else
  554.                         begin
  555.                           { Not to complicate the code generator too much, and since some  }
  556.                           { of the systems only support this format, the stackframe cannot }
  557.                           { exceed 32K in size.                                            }
  558.                           if (stackframe > -32767) and (stackframe < 32769) then
  559.                             begin
  560.                               procinfo.aktentrycode^.insert(new(pai68k,op_const_reg(A_SUB,S_L,stackframe,R_SP)));
  561.                               { IF only NOT in main program do we check the stack normally }
  562.                               if (cs_check_stack in aktswitches)
  563.                               and (aktprocsym^.definition^.options and poproginit=0) then
  564.                                 begin
  565.                                    procinfo.aktentrycode^.insert(new(pai68k,
  566.                                      op_csymbol(A_JSR,S_NO,newcsymbol('STACKCHECK',0))));
  567.                                   procinfo.aktentrycode^.insert(new(pai68k,op_const_reg(A_MOVE,S_L,
  568.                                     stackframe,R_D0)));
  569.                                    concat_external('STACKCHECK',EXT_NEAR);
  570.                                 end;
  571.                                procinfo.aktentrycode^.insert(new(pai68k,op_reg_reg(A_MOVE,S_L,R_SP,R_A6)));
  572.                                procinfo.aktentrycode^.insert(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A6,R_SPPUSH)));
  573.                             end
  574.                           else
  575.                             Message(cg_e_stacklimit_in_local_routine);
  576.                         end;
  577.                 end {endif stackframe<>0 }
  578.             else
  579.                begin
  580.                  procinfo.aktentrycode^.insert(new(pai68k,op_reg_reg(A_MOVE,S_L,R_SP,R_A6)));
  581.                  procinfo.aktentrycode^.insert(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A6,R_SPPUSH)));
  582.                end;
  583.         end;
  584.  
  585.  
  586.     if (aktprocsym^.definition^.options and pointerrupt)<>0 then
  587.         generate_interrupt_stackframe_entry;
  588.  
  589.     {proc_names.insert(aktprocsym^.definition^.mangledname);}
  590.  
  591.     if (aktprocsym^.definition^.owner^.symtabletype=globalsymtable) or
  592.      ((procinfo._class<>nil) and (procinfo._class^.owner^.
  593.      symtabletype=globalsymtable)) then
  594.         make_global:=true;
  595.     hs:=proc_names.get;
  596.  
  597. {$IfDef GDB}
  598.     if (cs_debuginfo in aktswitches) and
  599.      target_info.use_function_relative_addresses then
  600.         stab_function_name := new(pai_stab_function_name,init(strpnew(hs)));
  601.       oldaktprocname:=aktprocsym^.name;
  602. {$EndIf GDB}
  603.  
  604.  
  605.     while hs<>'' do
  606.         begin
  607.               if make_global then
  608.                 procinfo.aktentrycode^.insert(new(pai_symbol,init_global(hs)))
  609.               else
  610.                 procinfo.aktentrycode^.insert(new(pai_symbol,init(hs)));
  611. {$ifdef GDB}
  612.             if (cs_debuginfo in aktswitches) and
  613.              target_info.use_function_relative_addresses then
  614.             begin
  615.             procinfo.aktentrycode^.insert(new(pai_stab_function_name,init(strpnew(hs))));
  616.               { This is not a nice solution to save the name, change it and restore when done }
  617.                  aktprocsym^.setname(hs);
  618.                  procinfo.aktentrycode^.insert(new(pai_stabs,init(aktprocsym^.stabstring)));
  619.         end;
  620. {$endif GDB}
  621.               hs:=proc_names.get;
  622.         end;
  623. {$ifdef GDB}
  624.       aktprocsym^.setname(oldaktprocname);
  625.  
  626.     if (cs_debuginfo in aktswitches) then
  627.         begin
  628.             if target_info.use_function_relative_addresses then
  629.                 procinfo.aktentrycode^.insert(stab_function_name);
  630.             if make_global or ((procinfo.flags and pi_is_global) <> 0) then
  631.                 aktprocsym^.is_global := True;
  632.             aktprocsym^.isstabwritten:=true;
  633.         end;
  634. {$endif GDB}
  635.     { Alignment required for Motorola }
  636.     procinfo.aktentrycode^.insert(new(pai_align,init(2)));
  637. {$ifdef extdebug}
  638.     procinfo.aktentrycode^.insert(new(pai_direct,init(strpnew(target_info.newline))));
  639. {$endif extdebug}
  640. end;
  641.  
  642. {Generate the exit code for a procedure.}
  643. procedure genexitcode(parasize:longint;nostackframe:boolean);
  644.  
  645. var hr:Preference;          {This is for function results.}
  646.     op:Tasmop;
  647.     s:Topsize;
  648.  
  649. begin
  650.     { !!!! insert there automatic destructors }
  651.  
  652.     procinfo.aktexitcode^.insert(new(pai_label,init(aktexitlabel)));
  653.  
  654.     { call the destructor help procedure }
  655.     if (aktprocsym^.definition^.options and podestructor)<>0 then
  656.      begin
  657.        if procinfo._class^.isclass then
  658.          begin
  659.            procinfo.aktexitcode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO,
  660.              newcsymbol('DISPOSE_CLASS',0))));
  661.            concat_external('DISPOSE_CLASS',EXT_NEAR);
  662.          end
  663.        else
  664.          begin
  665.            procinfo.aktexitcode^.insert(new(pai68k,op_csymbol(A_JSR,S_NO,
  666.              newcsymbol('HELP_DESTRUCTOR',0))));
  667.            concat_external('HELP_DESTRUCTOR',EXT_NEAR);
  668.          end;
  669.      end;
  670.  
  671.     { call __EXIT for main program }
  672.     { ????????? }
  673.     if ((aktprocsym^.definition^.options and poproginit)<>0) and
  674.       (target_info.target<>target_PalmOS) then
  675.      begin
  676.        procinfo.aktexitcode^.concat(new(pai68k,op_csymbol(A_JSR,S_NO,newcsymbol('__EXIT',0))));
  677.        externals^.concat(new(pai_external,init('__EXIT',EXT_NEAR)));
  678.      end;
  679.  
  680.     { handle return value }
  681.     if (aktprocsym^.definition^.options and poassembler)=0 then
  682.         if (aktprocsym^.definition^.options and poconstructor)=0 then
  683.             begin
  684.                 if procinfo.retdef<>pdef(voiddef) then
  685.                     begin
  686.                         if not procinfo.funcret_is_valid then
  687.                           Message(sym_w_function_result_not_set);
  688.                         new(hr);
  689.                         reset_reference(hr^);
  690.                         hr^.offset:=procinfo.retoffset;
  691.                         hr^.base:=procinfo.framepointer;
  692.                         if (procinfo.retdef^.deftype=orddef) then
  693.                             begin
  694.                                 case porddef(procinfo.retdef)^.typ of
  695.                                     s32bit,u32bit :
  696.                                         procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hr,R_D0)));
  697.                                     u8bit,s8bit,uchar,bool8bit :
  698.                                         procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,hr,R_D0)));
  699.                                     s16bit,u16bit :
  700.                                         procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,hr,R_D0)));
  701.                                 end;
  702.                             end
  703.                         else
  704.                             if (procinfo.retdef^.deftype in [pointerdef,enumdef,procvardef]) or
  705.                              ((procinfo.retdef^.deftype=setdef) and
  706.                              (psetdef(procinfo.retdef)^.settype=smallset)) then
  707.                                 procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hr,R_D0)))
  708.                             else
  709.                                 if (procinfo.retdef^.deftype=floatdef) then
  710.                                     begin
  711.                                         if pfloatdef(procinfo.retdef)^.typ=f32bit then
  712.                                             begin
  713.                                                 { Isnt this missing ? }
  714.                                                 procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hr,R_D0)));
  715.                                             end
  716.                                         else
  717.                                             begin
  718.                                              { how the return value is handled                          }
  719.                                              { if single value, then return in d0, otherwise return in  }
  720.                                              { TRUE FPU register (does not apply in emulation mode)     }
  721.                                              if (pfloatdef(procinfo.retdef)^.typ = s32real) then
  722.                                               begin
  723.                                                 procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,
  724.                                                   S_L,hr,R_D0)))
  725.                                               end
  726.                                              else
  727.                                               begin
  728.                                                if cs_fp_emulation in aktswitches then
  729.                                                  procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_MOVE,
  730.                                                     S_L,hr,R_D0)))
  731.                                                else
  732.                                                  procinfo.aktexitcode^.concat(new(pai68k,op_ref_reg(A_FMOVE,
  733.                                                  getfloatsize(pfloatdef(procinfo.retdef)^.typ),hr,R_FP0)));
  734.                                              end;
  735.                                            end;
  736.                                     end
  737.                                 else
  738.                                     dispose(hr);
  739.                     end
  740.             end
  741.         else
  742.             begin
  743.                 { successful constructor deletes the zero flag }
  744.                 { and returns self in accumulator              }
  745.                 procinfo.aktexitcode^.concat(new(pai_label,init(quickexitlabel)));
  746.                 { eax must be set to zero if the allocation failed !!! }
  747.                 procinfo.aktexitcode^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,R_A5,R_D0)));
  748.                 { faster then OR on mc68000/mc68020 }
  749.                 procinfo.aktexitcode^.concat(new(pai68k,op_reg(A_TST,S_L,R_D0)));
  750.             end;
  751.     procinfo.aktexitcode^.concat(new(pai_label,init(aktexit2label)));
  752.     if not(nostackframe) then
  753.         procinfo.aktexitcode^.concat(new(pai68k,op_reg(A_UNLK,S_NO,R_A6)));
  754.  
  755.     { at last, the return is generated }
  756.  
  757.     if (aktprocsym^.definition^.options and pointerrupt)<>0 then
  758.         generate_interrupt_stackframe_exit
  759.     else
  760.         if (parasize=0) or ((aktprocsym^.definition^.options and poclearstack)<>0)
  761.         then
  762.             {Routines with the poclearstack flag set use only a ret.}
  763.             { also routines with parasize=0           }
  764.             procinfo.aktexitcode^.concat(new(pai68k,op_none(A_RTS,S_NO)))
  765.         else
  766.             { return with immediate size possible here }
  767.             { signed!                                  }
  768.             if (opt_processors = MC68020) and (parasize < $7FFF) then
  769.                 procinfo.aktexitcode^.concat(new(pai68k,op_const(
  770.                  A_RTD,S_NO,parasize)))
  771.             { manually restore the stack }
  772.             else
  773.               begin
  774.                     { We must pull the PC Counter from the stack, before  }
  775.                     { restoring the stack pointer, otherwise the PC would }
  776.                     { point to nowhere!                                   }
  777.  
  778.                     { save the PC counter (pop it from the stack)         }
  779.                     procinfo.aktexitcode^.concat(new(pai68k,op_reg_reg(
  780.                          A_MOVE,S_L,R_SPPULL,R_A0)));
  781.                     { can we do a quick addition ... }
  782.                     if (parasize > 0) and (parasize < 9) then
  783.                        procinfo.aktexitcode^.concat(new(pai68k,op_const_reg(
  784.                          A_ADD,S_L,parasize,R_SP)))
  785.                     else { nope ... }
  786.                        procinfo.aktexitcode^.concat(new(pai68k,op_const_reg(
  787.                          A_ADD,S_L,parasize,R_SP)));
  788.                     { endif }
  789.                     { restore the PC counter (push it on the stack)       }
  790.                     procinfo.aktexitcode^.concat(new(pai68k,op_reg_reg(
  791.                          A_MOVE,S_L,R_A0,R_SPPUSH)));
  792.                     procinfo.aktexitcode^.concat(new(pai68k,op_none(
  793.                       A_RTS,S_NO)))
  794.                end;
  795. {$ifdef GDB}
  796.     if cs_debuginfo in aktswitches  then
  797.         begin
  798.             aktprocsym^.concatstabto(procinfo.aktexitcode);
  799.             if assigned(procinfo._class) then
  800.                 procinfo.aktexitcode^.concat(new(pai_stabs,init(strpnew(
  801.                  '"$t:v'+procinfo._class^.numberstring+'",'+
  802.                  tostr(N_PSYM)+',0,0,'+tostr(procinfo.esi_offset)))));
  803.  
  804.             if (porddef(aktprocsym^.definition^.retdef) <> voiddef) then
  805.                 procinfo.aktexitcode^.concat(new(pai_stabs,init(strpnew(
  806.                  '"'+aktprocsym^.name+':X'+aktprocsym^.definition^.retdef^.numberstring+'",'+
  807.                  tostr(N_PSYM)+',0,0,'+tostr(procinfo.retoffset)))));
  808.  
  809.             procinfo.aktexitcode^.concat(new(pai_stabn,init(strpnew('192,0,0,'
  810.              +aktprocsym^.definition^.mangledname))));
  811.  
  812.             procinfo.aktexitcode^.concat(new(pai_stabn,init(strpnew('224,0,0,'
  813.              +lab2str(aktexit2label)))));
  814.         end;
  815. {$endif * GDB *}
  816. end;
  817.  
  818.  
  819.     { USES REGISTERS R_A0 AND R_A1 }
  820.     { maximum size of copy is 65535 bytes                                       }
  821.     procedure concatcopy(source,dest : treference;size : longint;delsource : boolean);
  822.  
  823.       var
  824.          ecxpushed : boolean;
  825.          helpsize : longint;
  826.          i : byte;
  827.          reg8,reg32 : tregister;
  828.          swap : boolean;
  829.          hregister : tregister;
  830.          iregister : tregister;
  831.          jregister : tregister;
  832.          hp1 : treference;
  833.          hp2 : treference;
  834.          hl : plabel;
  835.          hl2: plabel;
  836.       begin
  837.          { this should never occur }
  838.          if size > 65535 then
  839.            internalerror(0);
  840.          hregister := getregister32;
  841.          if delsource then
  842.            del_reference(source);
  843.  
  844.          { from 12 bytes movs is being used }
  845.          if (size<=8) or (not(cs_littlesize in aktswitches) and (size<=12)) then
  846.            begin
  847.               helpsize:=size div 4;
  848.               { move a dword x times }
  849.               for i:=1 to helpsize do
  850.                 begin
  851.                    exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(source),hregister)));
  852.                    exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,hregister,newreference(dest))));
  853.                    inc(source.offset,4);
  854.                    inc(dest.offset,4);
  855.                    dec(size,4);
  856.                 end;
  857.               { move a word }
  858.               if size>1 then
  859.                 begin
  860.                    exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,newreference(source),hregister)));
  861.                    exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_W,hregister,newreference(dest))));
  862.                    inc(source.offset,2);
  863.                    inc(dest.offset,2);
  864.                    dec(size,2);
  865.                 end;
  866.               { move a single byte }
  867.               if size>0 then
  868.                 begin
  869.                   exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,newreference(source),hregister)));
  870.                   exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_B,hregister,newreference(dest))));
  871.                 end
  872.  
  873.            end
  874.            else
  875.            begin
  876.               if (usableaddress > 1) then
  877.                 begin
  878.                     iregister := getaddressreg;
  879.                     jregister := getaddressreg;
  880.                 end
  881.               else
  882.               if (usableaddress = 1) then
  883.                 begin
  884.                     iregister := getaddressreg;
  885.                     jregister := R_A1;
  886.                 end
  887.               else
  888.                 begin
  889.                     iregister := R_A0;
  890.                     jregister := R_A1;
  891.                 end;
  892.               { reference for move (An)+,(An)+ }
  893.               reset_reference(hp1);
  894.               hp1.base := iregister;   { source register }
  895.               hp1.direction := dir_inc;
  896.               reset_reference(hp2);
  897.               hp2.base := jregister;
  898.               hp2.direction := dir_inc;
  899.               { iregister = source }
  900.               { jregister = destination }
  901.  
  902.  
  903.               exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(source),iregister)));
  904.               exprasmlist^.concat(new(pai68k,op_ref_reg(A_LEA,S_L,newreference(dest),jregister)));
  905.  
  906.               { double word move only on 68020+ machines }
  907.               { because of possible alignment problems   }
  908.               { use fast loop mode }
  909.               if (opt_processors=MC68020) then
  910.                 begin
  911.                    helpsize := size - size mod 4;
  912.                    size := size mod 4;
  913.                    exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,helpsize div 4,hregister)));
  914.                    getlabel(hl2);
  915.                    emitl(A_BRA,hl2);
  916.                    getlabel(hl);
  917.                    emitl(A_LABEL,hl);
  918.                    exprasmlist^.concat(new(pai68k,op_ref_ref(A_MOVE,S_L,newreference(hp1),newreference(hp2))));
  919.                    emitl(A_LABEL,hl2);
  920.                    exprasmlist^.concat(new(pai_labeled, init_reg(A_DBRA,hl,hregister)));
  921.                    if size > 1 then
  922.                      begin
  923.                         dec(size,2);
  924.                         exprasmlist^.concat(new(pai68k,op_ref_ref(A_MOVE,S_W,newreference(hp1), newreference(hp2))));
  925.                      end;
  926.                    if size = 1 then
  927.                     exprasmlist^.concat(new(pai68k,op_ref_ref(A_MOVE,S_B,newreference(hp1), newreference(hp2))));
  928.                 end
  929.               else
  930.                 begin
  931.                    { Fast 68010 loop mode with no possible alignment problems }
  932.                    helpsize := size;
  933.                    exprasmlist^.concat(new(pai68k,op_const_reg(A_MOVE,S_L,helpsize,hregister)));
  934.                    getlabel(hl2);
  935.                    emitl(A_BRA,hl2);
  936.                    getlabel(hl);
  937.                    emitl(A_LABEL,hl);
  938.                    exprasmlist^.concat(new(pai68k,op_ref_ref(A_MOVE,S_B,newreference(hp1),newreference(hp2))));
  939.                    emitl(A_LABEL,hl2);
  940.                    exprasmlist^.concat(new(pai_labeled, init_reg(A_DBRA,hl,hregister)));
  941.                 end;
  942.  
  943.        { restore the registers that we have just used olny if they are used! }
  944.               if jregister = R_A1 then
  945.                 hp2.base := R_NO;
  946.               if iregister = R_A0 then
  947.                 hp1.base := R_NO;
  948.               del_reference(hp1);
  949.               del_reference(hp2);
  950.            end;
  951.  
  952.            { loading SELF-reference again }
  953.            maybe_loada5;
  954.  
  955.            if delsource then
  956.                ungetiftemp(source);
  957.  
  958.            ungetregister32(hregister);
  959.     end;
  960.  
  961.  
  962.     procedure emitloadord2reg(location:Tlocation;orddef:Porddef;
  963.                               destreg:Tregister;delloc:boolean);
  964.  
  965.     {A lot smaller and less bug sensitive than the original unfolded loads.}
  966.  
  967.     var tai:pai68k;
  968.         r:Preference;
  969.  
  970.     begin
  971.         case location.loc of
  972.             LOC_REGISTER,LOC_CREGISTER:
  973.                 begin
  974.                     case orddef^.typ of
  975.                         u8bit: begin
  976.                                  exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,location.register,destreg)));
  977.                                  exprasmlist^.concat(new(pai68k,op_const_reg(A_ANDI,S_L,$FF,destreg)));
  978.                                end;
  979.                         s8bit: begin
  980.                                  exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_B,location.register,destreg)));
  981.                                  if (opt_processors <> MC68020) then
  982.                                   begin
  983.                                  { byte to word }
  984.                                      exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_W,destreg)));
  985.                                  { word to long }
  986.                                      exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,destreg)));
  987.                                   end
  988.                                  else { 68020+ and later only }
  989.                                      exprasmlist^.concat(new(pai68k,op_reg(A_EXTB,S_L,destreg)));
  990.                                 end;
  991.                         u16bit: begin
  992.                                  exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,location.register,destreg)));
  993.                                  exprasmlist^.concat(new(pai68k,op_const_reg(A_ANDI,S_L,$FFFF,destreg)));
  994.                                 end;
  995.                         s16bit: begin
  996.                                  exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_W,location.register,destreg)));
  997.                                  { word to long }
  998.                                  exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,destreg)));
  999.                                 end;
  1000.                         u32bit:
  1001.                             exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,location.register,destreg)));
  1002.                         s32bit:
  1003.                             exprasmlist^.concat(new(pai68k,op_reg_reg(A_MOVE,S_L,location.register,destreg)));
  1004.                     end;
  1005.                     if delloc then
  1006.                         ungetregister(location.register);
  1007.                 end;
  1008.             LOC_REFERENCE:
  1009.                 begin
  1010.                     r:=newreference(location.reference);
  1011.                     case orddef^.typ of
  1012.                         u8bit: begin
  1013.                                  exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,r,destreg)));
  1014.                                  exprasmlist^.concat(new(pai68k,op_const_reg(A_ANDI,S_L,$FF,destreg)));
  1015.                                end;
  1016.                         s8bit:  begin
  1017.                                  exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_B,r,destreg)));
  1018.                                  if (opt_processors <> MC68020) then
  1019.                                   begin
  1020.                                  { byte to word }
  1021.                                      exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_W,destreg)));
  1022.                                  { word to long }
  1023.                                      exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,destreg)));
  1024.                                   end
  1025.                                  else { 68020+ and later only }
  1026.                                      exprasmlist^.concat(new(pai68k,op_reg(A_EXTB,S_L,destreg)));
  1027.                                 end;
  1028.                         u16bit: begin
  1029.                                  exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,r,destreg)));
  1030.                                  exprasmlist^.concat(new(pai68k,op_const_reg(A_ANDI,S_L,$ffff,destreg)));
  1031.                                 end;
  1032.                         s16bit: begin
  1033.                                        exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_W,r,destreg)));
  1034.                                  { word to long }
  1035.                                  exprasmlist^.concat(new(pai68k,op_reg(A_EXT,S_L,destreg)));
  1036.                                 end;
  1037.                         u32bit:
  1038.                             exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,destreg)));
  1039.                         s32bit:
  1040.                             exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,r,destreg)));
  1041.                     end;
  1042.                     if delloc then
  1043.                         del_reference(location.reference);
  1044.                 end
  1045.             else
  1046.                 internalerror(6);
  1047.         end;
  1048.     end;
  1049.  
  1050.  
  1051.     { if necessary A5 is reloaded after a call}
  1052.     procedure maybe_loada5;
  1053.  
  1054.       var
  1055.          hp : preference;
  1056.          p : pprocinfo;
  1057.          i : longint;
  1058.  
  1059.       begin
  1060.          if assigned(procinfo._class) then
  1061.            begin
  1062.               if lexlevel>2 then
  1063.                 begin
  1064.                    new(hp);
  1065.                    reset_reference(hp^);
  1066.                    hp^.offset:=procinfo.framepointer_offset;
  1067.                    hp^.base:=procinfo.framepointer;
  1068.                    exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,R_A5)));
  1069.                    p:=procinfo.parent;
  1070.                    for i:=3 to lexlevel-1 do
  1071.                      begin
  1072.                         new(hp);
  1073.                         reset_reference(hp^);
  1074.                         hp^.offset:=p^.framepointer_offset;
  1075.                         hp^.base:=R_A5;
  1076.                         exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,R_A5)));
  1077.                         p:=p^.parent;
  1078.                      end;
  1079.                    new(hp);
  1080.                    reset_reference(hp^);
  1081.                    hp^.offset:=p^.ESI_offset;
  1082.                    hp^.base:=R_A5;
  1083.                    exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,R_A5)));
  1084.                 end
  1085.               else
  1086.                 begin
  1087.                    new(hp);
  1088.                    reset_reference(hp^);
  1089.                    hp^.offset:=procinfo.ESI_offset;
  1090.                    hp^.base:=procinfo.framepointer;
  1091.                    exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,hp,R_A5)));
  1092.                 end;
  1093.            end;
  1094.       end;
  1095.  
  1096.  
  1097.   (***********************************************************************)
  1098.   (* PROCEDURE FLOATLOAD                                                 *)
  1099.   (*  Description: This routine is to be called each time a location     *)
  1100.   (*   must be set to LOC_FPU and a value loaded into a FPU register.    *)
  1101.   (*                                                                     *)
  1102.   (*  Remark: The routine sets up the register field of LOC_FPU correctly*)
  1103.   (***********************************************************************)
  1104.  
  1105.     procedure floatload(t : tfloattype;const ref : treference; var location:tlocation);
  1106.  
  1107.       var
  1108.          op : tasmop;
  1109.          s : topsize;
  1110.  
  1111.       begin
  1112.         { no emulation }
  1113.         case t of
  1114.             s32real : s := S_S;
  1115.             s64real : s := S_Q;
  1116.             s80real : s := S_X;
  1117.          else
  1118.            begin
  1119.              Message(cg_f_unknown_float_type);
  1120.            end;
  1121.         end; { end case }
  1122.         location.loc := LOC_FPU;
  1123.         if not ((cs_fp_emulation) in aktswitches) then
  1124.         begin
  1125.             location.fpureg := getfloatreg;
  1126.             exprasmlist^.concat(new(pai68k,op_ref_reg(A_FMOVE,s,newreference(ref),location.fpureg)))
  1127.         end
  1128.         else
  1129.         { handle emulation }
  1130.         begin
  1131.           if t = s32real then
  1132.           begin
  1133.             location.fpureg := getregister32;
  1134.             exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVE,S_L,newreference(ref),location.fpureg)))
  1135.           end
  1136.           else
  1137.              { other floating types are not supported in emulation mode }
  1138.             Message(sym_e_type_id_not_defined);
  1139.         end;
  1140.       end;
  1141.  
  1142. {    procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize);
  1143.  
  1144.       begin
  1145.          case t of
  1146.             s32real : begin
  1147.                          op:=A_FSTP;
  1148.                          s:=S_S;
  1149.                       end;
  1150.             s64real : begin
  1151.                          op:=A_FSTP;
  1152.                          s:=S_L;
  1153.                       end;
  1154.             s80real : begin
  1155.                          op:=A_FSTP;
  1156.                          s:=S_Q;
  1157.                       end;
  1158.             s64bit : begin
  1159.                          op:=A_FISTP;
  1160.                          s:=S_Q;
  1161.                       end;
  1162.             else internalerror(17);
  1163.          end;
  1164.       end; }
  1165.  
  1166.  
  1167.     { stores an FPU value to memory }
  1168.     { location:tlocation used to free up FPU register }
  1169.     { ref: destination of storage                     }
  1170.     procedure floatstore(t : tfloattype;var location:tlocation; const ref:treference);
  1171.  
  1172.       var
  1173.          op : tasmop;
  1174.          s : topsize;
  1175.  
  1176.       begin
  1177.         if location.loc <> LOC_FPU then
  1178.          InternalError(34);
  1179.         { no emulation }
  1180.         case t of
  1181.             s32real : s := S_S;
  1182.             s64real : s := S_Q;
  1183.             s80real : s := S_X;
  1184.          else
  1185.            begin
  1186.              Message(cg_f_unknown_float_type);
  1187.            end;
  1188.         end; { end case }
  1189.         if not ((cs_fp_emulation) in aktswitches) then
  1190.         begin
  1191.             { This permits the mixing of emulation and non-emulation routines }
  1192.             { only possible for REAL = SINGLE values                          }
  1193.             if not (location.fpureg in [R_FP0..R_FP7]) then
  1194.              Begin
  1195.                if s = S_S then
  1196.                  exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,location.fpureg,newreference(ref))))
  1197.                else
  1198.                  internalerror(255);
  1199.              end
  1200.             else
  1201.                exprasmlist^.concat(new(pai68k,op_reg_ref(A_FMOVE,s,location.fpureg,newreference(ref))));
  1202.             ungetregister(location.fpureg);
  1203.         end
  1204.         else
  1205.         { handle emulation }
  1206.         begin
  1207.           if t = s32real then
  1208.           begin
  1209.             exprasmlist^.concat(new(pai68k,op_reg_ref(A_MOVE,S_L,location.fpureg,newreference(ref))));
  1210.             ungetregister32(location.fpureg);
  1211.           end
  1212.           else
  1213.              { other floating types are not supported in emulation mode }
  1214.             Message(sym_e_type_id_not_defined);
  1215.         end;
  1216.         location.fpureg:=R_NO;  { no register in LOC_FPU now }
  1217.       end;
  1218.  
  1219.     procedure firstcomplex(p : ptree);
  1220.  
  1221.       var
  1222.          hp : ptree;
  1223.  
  1224.       begin
  1225.          { always calculate boolean AND and OR from left to right }
  1226.          if ((p^.treetype=orn) or (p^.treetype=andn)) and
  1227.            (p^.left^.resulttype^.deftype=orddef) and
  1228.            (porddef(p^.left^.resulttype)^.typ=bool8bit) then
  1229.            p^.swaped:=false
  1230.          else if (p^.left^.registers32<p^.right^.registers32)
  1231.  
  1232.            { the following check is appropriate, because all }
  1233.            { 4 registers are rarely used and it is thereby   }
  1234.            { achieved that the extra code is being dropped   }
  1235.            { by exchanging not commutative operators         }
  1236.            and (p^.right^.registers32<=4) then
  1237.            begin
  1238.               hp:=p^.left;
  1239.               p^.left:=p^.right;
  1240.               p^.right:=hp;
  1241.               p^.swaped:=true;
  1242.            end
  1243.          else p^.swaped:=false;
  1244.       end;
  1245.  
  1246.     procedure secondfuncret(var p : ptree);
  1247.  
  1248.       var
  1249.          hregister : tregister;
  1250.  
  1251.       begin
  1252.          clear_reference(p^.location.reference);
  1253.          p^.location.reference.base:=procinfo.framepointer;
  1254.          p^.location.reference.offset:=procinfo.retoffset;
  1255.          if ret_in_param(procinfo.retdef) then
  1256.            begin
  1257.               hregister:=getaddressreg;
  1258.               exprasmlist^.concat(new(pai68k,op_ref_reg(A_MOVEA,S_L,newreference(p^.location.reference),hregister)));
  1259.               p^.location.reference.base:=hregister;
  1260.               p^.location.reference.offset:=0;
  1261.            end;
  1262.       end;
  1263.  
  1264.     procedure codegen_newprocedure;
  1265.  
  1266.       begin
  1267.          aktbreaklabel:=nil;
  1268.          aktcontinuelabel:=nil;
  1269.          { aktexitlabel:=0; is store in oldaktexitlabel
  1270.            so it must not be reset to zero before this storage !}
  1271.  
  1272.          { the type of this lists isn't important }
  1273.          { because the code of this lists is      }
  1274.          { copied to the code segment             }
  1275.          procinfo.aktentrycode:=new(paasmoutput,init);
  1276.          procinfo.aktexitcode:=new(paasmoutput,init);
  1277.          procinfo.aktproccode:=new(paasmoutput,init);
  1278.       end;
  1279.  
  1280.     procedure codegen_doneprocedure;
  1281.  
  1282.       begin
  1283.          dispose(procinfo.aktentrycode,done);
  1284.          dispose(procinfo.aktexitcode,done);
  1285.          dispose(procinfo.aktproccode,done);
  1286.       end;
  1287.  
  1288.     procedure codegen_newmodule;
  1289.  
  1290.       begin
  1291.          exprasmlist:=new(paasmoutput,init);
  1292.       end;
  1293.  
  1294.     procedure codegen_donemodule;
  1295.  
  1296.       begin
  1297.          dispose(exprasmlist,done);
  1298.          dispose(codesegment,done);
  1299.          dispose(bsssegment,done);
  1300.          dispose(datasegment,done);
  1301.          dispose(debuglist,done);
  1302.          dispose(externals,done);
  1303.          dispose(consts,done);
  1304.       end;
  1305.  
  1306.   end.
  1307. {
  1308.   $Log: cga68k.pas,v $
  1309.   Revision 1.2.2.7  1998/08/14 12:04:36  carl
  1310.     * internalerror 10 bugfix with restore - was allocating two regs
  1311.  
  1312.   Revision 1.2.2.6  1998/08/13 18:20:21  florian
  1313.     * no call to exit is done, if the PalmOS is used
  1314.  
  1315.   Revision 1.2.2.5  1998/08/13 17:41:22  florian
  1316.     + some stuff for the PalmOS added
  1317.  
  1318.   Revision 1.2.2.4  1998/07/21 12:14:48  carl
  1319.     * restore: Would not restore the correct registers if it was a memory
  1320.       reference
  1321.     * maybe_push: pushes to make sure that at least one data and one
  1322.   address register are available
  1323.     * loadstring with symbolic name was not being taken care of
  1324.  
  1325.   Revision 1.2  1998/03/28 23:09:54  florian
  1326.     * secondin bugfix (m68k and i386)
  1327.     * overflow checking bugfix (m68k and i386) -- pretty useless in
  1328.       secondadd, since everything is done using 32-bit
  1329.     * loading pointer to routines hopefully fixed (m68k)
  1330.     * flags problem with calls to RTL internal routines fixed (still strcmp
  1331.       to fix) (m68k)
  1332.     * #ELSE was still incorrect (didn't take care of the previous level)
  1333.     * problem with filenames in the command line solved
  1334.     * problem with mangledname solved
  1335.     * linking name problem solved (was case insensitive)
  1336.     * double id problem and potential crash solved
  1337.     * stop after first error
  1338.     * and=>test problem removed
  1339.     * correct read for all float types
  1340.     * 2 sigsegv fixes and a cosmetic fix for Internal Error
  1341.     * push/pop is now correct optimized (=> mov (%esp),reg)
  1342.  
  1343.   Revision 1.1.1.1  1998/03/25 11:18:13  root
  1344.   * Restored version
  1345.  
  1346.   Revision 1.15  1998/03/22 12:45:38  florian
  1347.     * changes of Carl-Eric to m68k target commit:
  1348.       - wrong nodes because of the new string cg in intel, I had to create
  1349.         this under m68k also ... had to work it out to fix potential alignment
  1350.         problems --> this removes the crash of the m68k compiler.
  1351.       - added absolute addressing in m68k assembler (required for Amiga startup)
  1352.       - fixed alignment problems (because of byte return values, alignment
  1353.         would not be always valid) -- is this ok if i change the offset if odd in
  1354.         setfirsttemp ?? -- it seems ok...
  1355.  
  1356.   Revision 1.14  1998/03/10 04:20:37  carl
  1357.     * extdebug problems
  1358.     - removed loadstring as it is not required for the m68k
  1359.  
  1360.   Revision 1.13  1998/03/10 01:17:16  peter
  1361.     * all files have the same header
  1362.     * messages are fully implemented, EXTDEBUG uses Comment()
  1363.     + AG... files for the Assembler generation
  1364.  
  1365.   Revision 1.12  1998/03/09 10:44:35  peter
  1366.     + string='', string<>'', string:='', string:=char optimizes (the first 2
  1367.       were already in cg68k2)
  1368.  
  1369.   Revision 1.11  1998/03/06 00:52:03  peter
  1370.     * replaced all old messages from errore.msg, only ExtDebug and some
  1371.       Comment() calls are left
  1372.     * fixed options.pas
  1373.  
  1374.   Revision 1.10  1998/03/03 04:12:04  carl
  1375.     * moved generate routines to this unit
  1376.  
  1377.   Revision 1.9  1998/03/02 01:48:17  peter
  1378.     * renamed target_DOS to target_GO32V1
  1379.     + new verbose system, merged old errors and verbose units into one new
  1380.       verbose.pas, so errors.pas is obsolete
  1381.  
  1382.   Revision 1.8  1998/02/13 10:34:45  daniel
  1383.   * Made Motorola version compilable.
  1384.   * Fixed optimizer
  1385.  
  1386.   Revision 1.7  1998/02/12 11:49:50  daniel
  1387.   Yes! Finally! After three retries, my patch!
  1388.  
  1389.   Changes:
  1390.  
  1391.   Complete rewrite of psub.pas.
  1392.   Added support for DLL's.
  1393.   Compiler requires less memory.
  1394.   Platform units for each platform.
  1395.  
  1396.   Revision 1.6  1998/01/11 03:39:02  carl
  1397.   * bugfix of concatcopy , was using wrong reference
  1398.   * bugfix of MOVEQ
  1399.  
  1400.   Revision 1.3  1997/12/09 13:30:05  carl
  1401.   + renamed some stuff
  1402.  
  1403.   Revision 1.2  1997/12/03 13:59:01  carl
  1404.   + added emitcall as in i386 version.
  1405.  
  1406.   Revision 1.1.1.1  1997/11/27 08:32:53  michael
  1407.   FPC Compiler CVS start
  1408.  
  1409.  
  1410.   Pre-CVS log:
  1411.  
  1412.   CEC   Carl-Eric Codere
  1413.   FK    Florian Klaempfl
  1414.   PM    Pierre Muller
  1415.   +     feature added
  1416.   -     removed
  1417.   *     bug fixed or changed
  1418.  
  1419.   History:
  1420.   27th september 1997:
  1421.     + first version for MC68000 (using v093 template) (CEC)
  1422.   9th october 1997:
  1423.     * fixed a bug in push_int as well as other routines which used
  1424.       getregister32 while they are not supposed to (because of how
  1425.       the allocation of registers work in parser.pas) (CEC)
  1426.     * Fixed some bugs in the concatcopy routine, was allocating
  1427.       registers which were not supposed to be allocated. (CEC)
  1428.  
  1429. }
  1430.