GcodeLowC

module GcodeLowC
  ( gcodeGather
  , gcodeCHeader
  ) where



import Char

import Gcode
import GcodeLow (offsetSize
                ,shortNeedheap,shortNeedstack,shortPush,shortPop
                ,shortPushArg,shortZapArg,shortHeapCval,shortHeap
                ,fun,foreignfun,showId)
import Extra(strStr,splitIntegral,SplitIntegral(..))
import IntState(strIS,IntState,dummyIntState)
import EmitState
import Prim(strPrim)
import Machine


sfun  = fun
ffun  = foreignfun

----------------------------------------
gcodeCHeader = "#include \"newmacros.h\"\n#include \"runtime.h\"\n\n"

----------------------------------------

emitJump p j i =
  emitByte p (j)       >|>
  emitByte p (show l)  >|>
  emitByte p (show h)
 where
  (h,l) = divMod i 256

emitOp p op =  emitByte p (op)

emitOp1 p op i =
  emitByte p (op)     >|>
  emitByte p (show i)

emitOp2 p op i j =
  emitByte p (op)     >|>
  emitByte p (show i) >|>
  emitByte p (show j)

emitOp12 p op i =
  if i < 0 then
    case (-i) `divMod` 256 of
      (0,l) -> emitByte p (op ++ "_N1") >|>
               emitByte p (show l)
      (h,l) -> emitByte p (op ++ "_N2") >|>
               emitByte p (show l) >|>
               emitByte p (show h)
  else
    case i `divMod` 256 of
      (0,l) -> emitByte p (op ++ "_P1") >|>
               emitByte p (show l)
      (h,l) -> emitByte p (op ++ "_P2") >|>
               emitByte p (show l)      >|>
               emitByte p (show h)


shortQ p pred defgen opstr arg  =
  case pred arg of
    (True,argstr) -> emitOp p (opstr ++ "_I" ++ argstr)
    _             -> defgen opstr arg

gcodeCDump p state (ALIGN)         = emitAlign p
gcodeCDump p state (ALIGN_CONST)   = emitOp p "ENDCODE" >|> emitAlignDouble p
gcodeCDump p state (NEEDHEAP i)    = shortQ p shortNeedheap (emitOp12 p)
                                                                  "NEEDHEAP" i
gcodeCDump p state (NEEDSTACK i)   = shortQ p shortNeedstack (emitOp12 p)
                                                                 "NEEDSTACK" i
gcodeCDump p state (LABEL i)       = defineLabel p Local (showId state i "")
gcodeCDump p state (LOCAL s i)     = defineLabel p Local
                                               (s ++ showId state i "")
gcodeCDump p state (GLOBAL s i)    = defineLabel p Global
                                               (s ++ showId state i "")
gcodeCDump p state (JUMP  i)       = emitJump p "JUMP" i
gcodeCDump p state (JUMPFALSE i)   = emitJump p "JUMPFALSE" i		-- DAVID
gcodeCDump p state (PRIMITIVE)     = emitOp p "PRIMITIVE"
gcodeCDump p state (PRIM prim)     = emitOp p (strPrim prim)
gcodeCDump p state (NOP)           = emitOp p "NOP"
gcodeCDump p state (MKIORETURN)    = emitOp p "MKIORETURN"	-- MW

gcodeCDump p state (TABLESWITCH size pad ls) =		-- DAVID
    emitOp1 p "TABLESWITCH" size >|>
    someNops p pad >|>
    someLabels p ls
gcodeCDump p state (LOOKUPSWITCH size pad tls def) =	-- DAVID
    emitOp1 p "LOOKUPSWITCH" size >|>
    someNops p pad >|>
    someLabels p (concatMap (\(f,s) -> [f,s]) tls ++ [def])

gcodeCDump p state (ZAP_ARG  i)     = shortQ p shortZapArg (emitOp1 p)
                                                                    "ZAP_ARG" i
gcodeCDump p state (ZAP_STACK i)    = emitOp12 p "ZAP_STACK" i

-- Stack
gcodeCDump p state (PUSH_CADR  i)   = emitOp12 p "PUSH_CADR" i
gcodeCDump p state (PUSH_CVAL  i)   = emitOp12 p "PUSH_CVAL" i
gcodeCDump p state (PUSH_INT  i)    = emitOp12 p "PUSH_INT" i
gcodeCDump p state (PUSH_CHAR  i)   = emitOp12 p "PUSH_CHAR" i
gcodeCDump p state (PUSH_ARG  i)    = shortQ p shortPushArg (emitOp1 p)
                                                                   "PUSH_ARG" i
gcodeCDump p state (PUSH_ZAP_ARG i) = shortQ p shortPushArg (emitOp1 p)
                                                               "PUSH_ZAP_ARG" i
gcodeCDump p state (PUSH      i)    = shortQ p shortPush (emitOp12 p)  "PUSH" i
gcodeCDump p state (PUSH_HEAP)      = emitOp p "PUSH_HEAP"
gcodeCDump p state (POP       i)    = shortQ p shortPop (emitOp12 p)    "POP" i
gcodeCDump p state (SLIDE     i)    = emitOp12 p  "SLIDE" i
gcodeCDump p state (UNPACK    i)    = emitOp1 p  "UNPACK" i

-- selector
gcodeCDump p state (SELECTOR_EVAL)  = emitOp p "SELECTOR_EVAL"
gcodeCDump p state (SELECT     i)   = emitOp1 p "SELECT" i

-- evaluation
gcodeCDump p state (APPLY     i)    = emitOp1 p "APPLY" i
gcodeCDump p state (EVAL)           = emitOp p "EVAL"
gcodeCDump p state (RETURN)         = emitOp p "RETURN"
gcodeCDump p state (RETURN_EVAL)    = emitOp p "RETURN_EVAL"

-- Heap
gcodeCDump p state (HEAP_CADR  i)   = emitOp12 p "HEAP_CADR" i
gcodeCDump p state (HEAP_CVAL  i)   = shortQ p shortHeapCval (emitOp12 p)
                                                                  "HEAP_CVAL" i
gcodeCDump p state (HEAP_INT  i)    = emitOp12 p "HEAP_INT" i
gcodeCDump p state (HEAP_CHAR  i)   = emitOp12 p "HEAP_CHAR" i
gcodeCDump p state (HEAP_ARG  i)    = emitOp1 p "HEAP_ARG" i 
gcodeCDump p state (HEAP_ARG_ARG i j)  = emitOp2 p "HEAP_ARG_ARG" i j
gcodeCDump p state (HEAP_ARG_ARG_RET_EVAL i j)  =
                                      emitOp2 p "HEAP_ARG_ARG_RET_EVAL" i j
gcodeCDump p state (HEAP      i)    = shortQ p shortHeap (emitOp12 p) "HEAP" i
gcodeCDump p state (HEAP_OFF  i)    = emitOp12 p "HEAP_OFF" i

gcodeCDump p state (HEAP_CREATE)    = emitOp p "HEAP_CREATE"
gcodeCDump p state (HEAP_SPACE)     = emitOp p "HEAP_SPACE"

gcodeCDump p state (DATA_CREATE)    = emitWord p ("0")
gcodeCDump p state (DATA_CAPITEM a b) = emitByte p (show b) >|>
                                        emitByte p (show a)
gcodeCDump p state (DATA_CONSTHEADER a b) = emitWord p ("HW(" ++
						        show a ++ ',':
						        show b ++ ")")
gcodeCDump p state (DATA_W  i)      = emitWord p (show i)
gcodeCDump p state (DATA_S  s)      = foldr (>|>) (emitByte p ("0"))
                                          (map (emitByte p.show.fromEnum) s)

gcodeCDump p state (DATA_NOP)       = id
gcodeCDump p state (DATA_CLABEL i)  = useLabel p (showCLabel state i "")
gcodeCDump p state (DATA_FLABEL i)  = useLabel p (ffun ++ showId state i "")
gcodeCDump p state (DATA_GLB s 0)   = useLabel p (s)
gcodeCDump p state (DATA_GLB s i)   = useLabel p (s ++ showId state i "")
gcodeCDump p state (DATA_VAP i)     = let lab = sfun ++ showId state i ""
                                      in
                                      mentionLabel p lab >|>
                                      emitWord p ("VAPTAG(" ++
					          wrapUse lab ++ ")")
gcodeCDump p state (DATA_CAP  i s)  = let lab = sfun ++ showId state i ""
                                      in
                                      mentionLabel p lab >|>
                                      emitWord p ("CAPTAG(" ++
					          wrapUse lab ++
					          ',': show s ++ ")")
gcodeCDump p state (DATA_CON  s c)  = emitWord p ("CONSTR(" ++
					          show c ++  ',':
					          show s ++  ",0)")
gcodeCDump p state (DATA_CONR s c)  = emitWord p ("CONSTRR(" ++
					          show c ++  ',':
					          show s ++  ",0)")
gcodeCDump p state (DATA_CONT s c)  = emitWord p ("CONSTRT(" ++
					          show c ++  ',':
					          show s ++  ",0)")
gcodeCDump p state (DATA_CONW s e)  = emitWord p ("CONSTRW(" ++
					          show s ++  ',':
			 		          show e ++  ")")
gcodeCDump p state (DATA_CONP s e)  = emitWord p ("CONSTRP(" ++
					          show s ++  ',':
			 		          show e ++  ")")


someNops :: Pass -> Int -> EmitState -> EmitState
someNops p pad = foldr (>|>) id (take pad (repeat (emitOp p "NOP")))

someLabels :: Pass -> [ Int ] -> EmitState -> EmitState
someLabels p cls =
  foldr (>|>) id (map (\l -> emitByte p ("TOP(" ++ show l ++ ")")   >|>
                             emitByte p ("BOT(" ++ show l ++ ")")
                      )
                      cls)

----------------------------------------
gcodeGather p state es [] = es
gcodeGather p state es list =
  (foldr (\a b-> gcodeCDump p state a >|> b) (emitAlign p) list) es