!Revision history:

!  3-Jul-87 PSR corrected assigning longreal values to real locations
!             - string(*)names were not being passed to %names properly

%routine Store(%record(Stackfm)%name R, L)
   %unless R_Oper = 0 %and Same(L, R) %start
      %if L_Type = Records %start
         Record Assign(R, L)
      %else %if L_Type = Strings
         String Assign(R, L)
      %else %if L_Type = Sets
         Set Assign(R, L)
      %else
         Move(R, L)
      %finish
   %finish
%end

%routine Assign Procedure(%record(Stackfm)%name R, L)
   {A procedure parameter is a pointer to a tw0-word vector}
   {There are four cases}
   {1. The procedure is an external  - <Ep><?>}
   {2. The procedure is a parameter  - pass the pointer}
   {3. The procedure is a safe local - pass <Ep><?> and mark the parameter}
   {                                   as needing an external entry}
   {4. The procedure is dangerous    - pass <Ep><Display> and work hard}
   %integer Mask
   %record(Stackfm)%name W, V
   %if R_Flags&Xproc Spec # 0 %start      {case 1 - an external}
      Hazard(R2)
      Dir2(Dir xThunk, R_Disp)            {         load @vector into R13}
      Refs = Refs+1;  Ca = Ca+4
      R == Register(R13)
   %else %if R_Flags&Parameter # 0        {case 2 - already a parameter}
      R_Type = Integers;  R_Form = Direct;  R_Area = 0
      R == Copy(R)
   %else %if R_Flags&XprocDef # 0         {case 3 - simplified}
      Hazard(R13)
      Dir2(Dir Thunk, R_Disp)             {         load @vector into R13}
      Refs = Refs+1;  Ca = Ca+4
      R == Register(R13)
   %else                                  {cases 3 & 4}
      Hazard(R13)
      Dir2(Dir Thunk, R_Disp)             {Load @Ep into R13}
      Ca = Ca+4;  Refs = Refs+1
      Claim(R13)
      Mask = 2_0010 0100 0000 0000        {R10, R13 = Sb, Ep}
      W == NIL
      %if R_Flags&Nasty Proc # 0 %start   {case 4 - a dangerous internal}
         Frame = Frame-4
         W == Literal(Local Display);  W_Base = Local
         Load(W, R14)
         Mask = 2_0110 0100 0000 0000     {R10, R13, R14 = Sb, Ep, Env}
      %finish
      Frame = Frame&(\3)-8
      R == Local Integer(Frame);  Loadup Address(R)
      Plant4(STM ! IA, R_Base, Mask)
      Release(R13)
      Release and Drop(W) %if W ## NIL
   %finish
   L_Type = Integers
   Simple(R, L)
   Release and Drop(R)
%end

%routine Assign Arrayname(%record(Stackfm)%name Array, To)
   %record(Stackfm)%name DopeVector
   Array_Type = Integers          {the header contains integer addresses}
   To   _Type = Integers
   %if Array_Flags&(Arrayname!Static) = 0 %start     {in a record}
      %if Array_Adata == Nil %start
         DopeVector == Literal(0)
      %else
         DopeVector == Literal(Array_Adata_DV)
         DopeVector_Area = Constant Area
      %finish
      Amap(Array)
   %else
      DopeVector == Copy(Array)
      Advance(DopeVector, Integers, Word Length)
   %finish
   Simplify(To)
   Advance(To, Integers, Word Length)
   Simple(DopeVector, To);  Release and Drop(DopeVector)  {dope-vector}
   Advance(To, Integers,-Word Length)
   Simple(Array, To)                                      {array0}
%end

%integerfn Select Best(%record(Stackfm)%name From, To, %integer Default)
   %record(Stackfm)%name W
   %integer Reg
   %result = Default %if InReg(From)
   W == Copy(To);  Optimise(W, 1)
   %if InReg(W) %and Activity(W_Base) = 1 %then Reg = W_Base {-}%c
                                          %else Reg = Default
   Release and Drop(W)
   %result = Reg
%end

%routine Move(%record(Stackfm)%name From, To)
   %record(Stackfm)%name Bf1, Bf2, Bt1, Bt2, W
   %integer R, Pa, N, Best, Op
   %if From_Oper = ADDx %and Pending Auto # 0 %start
      W == From_Link
      %if Iconst(W) %and -4095 <= W_Disp <= 4095 %start
         From_Oper = 0;  From_Link == NIL
         Pa = Pending Auto               {the optimise will destroy it}
         Optimise(From, 1)
         %if Inreg(From) %and From_Base = Pa {-}%c
             %and (Pending Auto N = 0 %or |W_Disp>>2| <= 255) %start
            Dir3(Dir Modify, Ca-Pending Auto Ca, W_Disp>>Pending Auto N)
            Forget(Pa)
            Drop(W)
         %else
            From_Oper = ADDx;  From_Link == W
         %finish
      %finish
   %finish
   %if From_Type = Shorts %and (From_Oper = ANDx %or From_Oper = BICx) {-}%c
                          %and To_Type = Integers                      {-}%c
                          %and Iconst(From_Link) %start
      N = From_Link_Disp
      N = \N %if From_Oper = BICx
      %if N&16_FFFF0000 = 0 %start
         Release and Drop(From_Link)
         From_Oper = 0;  From_Link == NIL
         %if N <= 255 %start
            Advance(From, Bytes, 0)                     {low byte}
            Operate(ANDx, From, Literal(N)) %if N # 255
         %else %if N&255 = 0
            Release and Drop(From_Link)
            From_Oper = 0;  From_Link = 0
            Advance(From, Bytes, 1)  {high byte}
            Operate(ANDx, From, Literal(N>>8)) %if N>>8 # 255
            Operate(LSHx, From, Literal(8))
         %else
            Best = Select Best(From, To, Any)
            Bf2 == Copy(From);  Advance(Bf2, Bytes, 1)  {high byte}
            Operate(ANDx, Bf2, Literal(N>>8)) %if N>>8 # 255
            Advance(From, Bytes, 0)  {low byte}
            Operate(ANDx, From, Literal(N&255)) %if N&255 # 255
            Loadup(Bf2);  Load Safely(From, Best)
            Loadup(Bf2);  Load Safely(From, Best)       {in case of hazard}
            Plant1(ORR, From_Base, From_Base, Ishift(Bf2_Base, 8, Logical Left))
            Release and Drop(Bf2)
         %finish
      %finish
   %finish
   %if To_Type = Shorts %start
      %if Iconst(From) %start
         Bf1 == Literal(From_Disp&255)               {low byte}
         Bf2 == Literal(From_Disp>>8&255)            {high byte}
      %else %if From_Type = Shorts %and From_Oper = 0
         %if From_Index ## NIL %or From_Record ## NIL %start
            Loadup Address(From);  From_Type = Shorts;  From_Form = Direct
         %finish
         Bf1 == Copy(From);  Advance(Bf1, Bytes, 0)  {low byte}
         Bf2 == Copy(From);  Advance(Bf2, Bytes, 1)  {high byte}
      %else %if From_Type = Bytes %and From_Oper = 0
         Bf1 == Copy(From);  Advance(Bf1, Bytes, 0)  {low byte}
         Bf2 == Literal(0)                           {high byte}
      %else
         Loadup(From)
         Bf1 == Copy(From)
         Bf2 == Copy(From);  Operate(RSHx, Bf2, Literal(8))
      %finish
      Bt1 == Copy(To);    Advance(Bt1, Bytes, 0)  {low byte}
      Bt2 == Copy(To);    Advance(Bt2, Bytes, 1)  {high byte}
      Move(Bf2, Bt2)                              {do the [b+1] side first}
      Move(Bf1, Bt1)                              {and the [b+0] side last}
      Release and Drop Pair(Bf1, Bt1)
      Release and Drop Pair(Bf2, Bt2)
   %else %if To_Type = Bytes
      From_Type = Bytes %if From_Oper = 0 %and From_Type = Shorts
      Simplify(To)
      Loadup(From)
      Plant2(STR ! Byte Op, From_Base, To)
   %else %if To_Type = Lreals
      Best = Select Best(From, To, AnyF)
      Simplify(To)
      Load(From, Best)
      Plant6(STFD, From_Base, To)
   %else %if To_Type = Reals
      %if Iconst(From) %and (-5 <= From_Disp <= 5 %or From_Disp =  10 {-}%c
                                                  %or From_Disp = -10) %start
         Op = MVF
         N = From_Disp
         Op = MNF %and N = -N %if N < 0
         N = 7 %if N = 10
         R = FPR
         Plant9(Op ! Small Constant, 0, R, N)
         Plant6(STFS, R, To)
      %else %if From_Form = Direct %and From_Oper = 0 %and From_Type = Reals
           To == Copy(To);      To_Type = Integers
         From == Copy(From);  From_Type = Integers
         Move(From, To)
         Forget(From_Base)
         Release and Drop Pair(From, To)
      %else
         Simplify(To)
         Load(From, AnyF)
         Plant6(STFS, From_Base, To)           {corrected for R0002.IMP}
      %finish
   %else
      Best = Select Best(From, To, Any)
      Simplify(To)
      Load(From, Best)
      Plant2(STR, From_Base, To)
   %finish
%end

%routine Move Literal(%integer Value, %record(Stackfm)%name To)
   %record(Stackfm)%name W == Literal(Value)
   Simple(W, To)
   Release and Drop(W)
%end

%routine Move Biased(%record(Stackfm)%name From, To, %integer Bias)
   From == Copy(From)
   To   == Copy(To)
   Advance(From, Integers, Bias) %if From_Form = Direct
   Advance(To,   Integers, Bias)
   Move(From, To)
   Release and Drop Pair(From, To)
%end

%routine Store Address(%record(Stackfm)%name R, L, %integername Extra)
   %record(Stackfm)%name W
   %integer Rt, Format
   %if L_Type = Generals %start
      L_Type = Integers                  {really three of them}
      Amap(L) %unless L_Form = AutoD
      Format = R_Format
      Rt = R_Type
      Amap(R)
      %if Rt = Generals %start
         Move Biased(R, L, WordLength*2)
         Move Biased(R, L, WordLength*1)
         Move       (R, L)
      %else
         W == Literal(Type Code(Rt))
         Move Biased(W, L, Wordlength*2)
         Release and Drop(W)
         %if Rt = Strings %and R_Form = Direct %and Format = 1 %start {(*)}
            Move Biased(R, L, Wordlength)
            Move       (R, L)
         %else
            W == Literal(Item Size(Format))
            Move Biased(W, L, Wordlength);  Release and Drop(W)
            Move       (R, L)
         %finish
      %finish
      Extra = Extra+12
   %else %if L_Form = Proc
      Assign Procedure(R, L)
      Extra = Extra+4
   %else %if L_Flags&Arrayname # 0
      Assign Arrayname(R, L)
      Extra = Extra+8
   %else %if L_Type = Strings %and L_Format = 1
      N = R_Format
      Amap(L)
      Amap(R)
      %if N = 1 %and R_Form # Address %start                  {string(*)name}
         Move Biased(R, L, Wordlength)
         Move       (R, L)
      %else
         W == Literal(N)
         Move Biased(W, L, Wordlength);  Release and Drop(W)
         Move       (R, L)
      %finish
      Extra = Extra+8
   %else
      %if L_Form = AutoD %then L_Type = Integers {-}%c
                         %else Amap(L)
      Amap(R)
      Store(R, L)
      Extra = Extra+4
   %finish
%end

%routine Jam Transfer(%record(Stackfm)%name L, R)
   %integer N, Type
   %record(Stackfm)%name M
   Type = L_Type
   %if Type # Strings %start                  {just omit the remember}
      Jamit = 1;  Store(R, L);  Jamit = 0
      Forget Destination(L)
   %else
      N = L_Format-1                          {maximum length}
      Evaluate String Expression(R) %if R_Oper # 0
      Amap(L);  Amap(R)
      %if N <= 0 %start                       {string(*)%name}
         M == Copy(L)
         M_Disp = M_Disp+Word Length;  M_Type = Integers
      %else
         M == Literal(N+1)
      %finish
      Load Trio(L, R2, R, R1, M, R0)
      Prim(Sjam)
      Release and Drop(M)
   %finish
%end

%routine Assign(%integer How)
   %integer X = 0
   %record(Varfm)%name V
   %record(Stackfm)%name L, R
   R == Stack
   L == R_Stack;  Stack == L_Stack
   %if Diag&MonMove # 0 %start
      Monitor(L, "A-L")
      Monitor(R, "A-R")
   %finish
   %if How = Equals %start
      Store(R, L)
   %else %if How = EqualsEquals
      Store Address(R, L, X)
   %else
      Jam Transfer(L, R)
   %finish
   %if Assign Lock # 0 %and L_Varno # 0 %start
      V == Var(L_Varno)
      V_Flags = V_Flags!Known Ass
   %finish
   Release and Drop Pair(R, L)
%end

%routine Assign Parameter
   %record(Stackfm)%name Par
   Par          == Stack                                {the parameter}
   Stack        == Par_Stack                            {the procedure}
     Par_Params == Stack_Params
   Stack_Params == Par
   Stack_Extra = Stack_Extra-1 %unless Stack_Extra = 0  {beware of C}
   Par_Varno   = Stack_Extra
%end

%record(Stackfm)%map To Temp(%record(Stackfm)%name V, %integer Size)
   %record(Stackfm)%name W
   W == Claim Work Area(Size, Strings)
   String Assign(V, W)
   Release and Drop(V)
   %result == W
%end

{%include "pparam.inc"
%endoffile