\
\    Mecrisp-Across - A Forth cross compiler for small MSP430 microcontrollers
\    Copyright (C) 2016  Matthias Koch
\
\    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 3 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, see <http://www.gnu.org/licenses/>.
\


\ -----------------------------------------------------------------------------
\   Schieben
\ -----------------------------------------------------------------------------

: $FF-and-opcode ( -- ) \ Ein kleines Helferlein, welches das untere Byte in einem Opcode maskiert.
  expect-one-element
  expect-tos-in-register
  make-tos-changeable
  $F370 state-tos @ or image,
;

true variable shift-vorspann

: t-lshift   ( x u -- x* ) lshift $FFFF and ;
: t-rshift   ( x u -- x* ) rshift ;
: t-arshift  ( x u -- x* ) 0 ?do t-2/ loop ;


: t-lshift-ra ( -- )

  zweikonstanten? if zweikonstanten t-lshift ergebnismerken exit then
  
  true shift-vorspann !
  einekonstante?
  not if else \ Der Sprungweite halber umgekehrt
    einekonstante
    
    dup  0  =  if drop                                 exit then  \ Null Stellen schieben -- nichts tun.
    dup  1  =  if drop t-shl-ra                        exit then
    dup  2  =  if drop t-shl-ra t-shl-ra               exit then
    dup  3  =  if drop t-shl-ra t-shl-ra t-shl-ra      exit then
    dup  4  =  if drop 4 0 do t-shl-ra loop            exit then
    dup  5  =  if drop 5 0 do t-shl-ra loop            exit then  \ Bis Schubweite 5 ist es noch genauso lang wie das klassische Schieben.

    dup  8  =  if drop $FF-and-opcode t-><-ra          exit then \ Schubweite 8: Swap Bytes und and.b #-1, r... zum Maskieren :-) Ergibt einen sehr kurzen Opcode !

    dup 16 u>= if drop eliminiere-tos 0 compileliteral exit then \ 16 oder mehr Stellen schieben: Ergibt Null.    

    ergebnismerken \ Andere Konstanten müssen "klassisch" geschoben werden...
    false shift-vorspann !
  then

  expect-two-elements
  expect-tos-in-register
  expect-nos-in-register
  
  make-tos-changeable
  t-swap-intern
  make-tos-changeable
  t-swap-intern

  shift-vorspann @ if
  $9300 state-tos @ or                         image, \ cmp #0, r-Schubweite
  $2400 4 or                                   image, \ jz +
  then
  
  t-swap-intern t-shl-ra t-swap-intern                \ add r-Daten, r-Daten
 \ $2400 2 or                                   image, \ jz +
  $8310 state-tos @ or                         image, \ subs #1, r-Schubweite
  $2000 $3FF 2 - or                            image, \ jnz -  
  
  eliminiere-tos
;

: t-rshift-ra ( -- )

  zweikonstanten? if zweikonstanten t-rshift ergebnismerken exit then

  true shift-vorspann !
  einekonstante?
  if  
    einekonstante
    
    dup  0  =  if drop                                 exit then  \ Null Stellen schieben -- nichts tun.
    dup  1  =  if drop t-shr-ra                        exit then
    dup  2  =  if drop t-shr-ra t-shr-ra               exit then
    dup  3  =  if drop t-shr-ra t-shr-ra t-shr-ra      exit then \ Bis Schubweite 3 ist es noch genauso lang wie das klassische Schieben.
    
    dup  8  =  if drop t-><-ra $FF-and-opcode          exit then \ Schubweite 8: Swap Bytes und and.b #-1, r... zum Maskieren :-) Ergibt einen sehr kurzen Opcode !
    
    dup 16 u>= if drop eliminiere-tos 0 compileliteral exit then \ 16 oder mehr Stellen schieben: Ergibt Null.
    
    ergebnismerken \ Andere Konstanten müssen "klassisch" geschoben werden...
    false shift-vorspann !
  then
    
  expect-two-elements
  expect-tos-in-register
  expect-nos-in-register
  
  make-tos-changeable
  t-swap-intern
  make-tos-changeable
  t-swap-intern

  shift-vorspann @ if
  $9300 state-tos @ or                         image, \ cmp #0, r-Schubweite
  $2400 5 or                                   image, \ jz +
  then
  
  t-swap-intern t-shr-ra t-swap-intern                \ bic.w #1h, r2
                                                      \ rrc.w r-Daten  
 \ $2400 2 or                                   image, \ jz +
  $8310 state-tos @ or                         image, \ subs #1, r-Schubweite
  $2000 $3FF 3 - or                            image, \ jnz -  
  
  eliminiere-tos
;

: t-arshift-ra ( -- )

  zweikonstanten? if zweikonstanten t-arshift ergebnismerken exit then

  true shift-vorspann !
  einekonstante?
  if  
    einekonstante
    
    dup  0  =  if drop                                 exit then  \ Null Stellen schieben -- nichts tun.
    dup  1  =  if drop t-2/-ra                         exit then
    dup  2  =  if drop t-2/-ra t-2/-ra                 exit then
    dup  3  =  if drop t-2/-ra t-2/-ra t-2/-ra         exit then
    dup  4  =  if drop t-2/-ra t-2/-ra t-2/-ra t-2/-ra           exit then
    dup  5  =  if drop t-2/-ra t-2/-ra t-2/-ra t-2/-ra t-2/-ra   exit then  \ Bis Schubweite 5 ist es noch genauso lang wie das klassische Schieben.
    
    dup 15 u>= if drop 0 compileliteral t-<-ra                   exit then \ 15 oder mehr Stellen schieben ergeben 0<
    
    ergebnismerken \ Andere Konstanten müssen "klassisch" geschoben werden...    
    false shift-vorspann !
  then
    
  expect-two-elements
  expect-tos-in-register
  expect-nos-in-register
  
  make-tos-changeable
  t-swap-intern
  make-tos-changeable
  t-swap-intern
      
  shift-vorspann @ if
  $9300 state-tos @ or                         image, \ cmp #0, r-Schubweite
  $2400 4 or                                   image, \ jz +
  then
  
  t-swap-intern t-2/-ra t-swap-intern                 \ rra r-Daten
\  $2400 2 or                                   image, \ jz +
  $8310 state-tos @ or                         image, \ subs #1, r-Schubweite
  $2000 $3FF 2 - or                            image, \ jnz -  
  
  eliminiere-tos
;

'  t-lshift  '  t-lshift-ra  t-prim-ra:  lshift  t-inline  2 t-foldable
'  t-rshift  '  t-rshift-ra  t-prim-ra:  rshift  t-inline  2 t-foldable
' t-arshift  ' t-arshift-ra  t-prim-ra: arshift  t-inline  2 t-foldable
 

 
