module Gcode
	( GALT(..),Gcode(..),showCLabel,strGcode,strGcodeRel
	, IntState, Prim(..), PrimOp(..),Pos) where

import Prim(Prim(..),PrimOp(..),strPrim)
import IntState(tidIS,strIS,IntState)
import TokenId(dropM)
import Util.Extra(Pos)

data GALT = GALT_CON Int | GALT_INT Int deriving (Eq)

data Gcode 
  = STARTFUN Int Int
  | NEEDHEAP Int
  | NEEDSTACK Int
  | LABEL Int
  | LOCAL String Int
  | GLOBAL String Int
  | JUMP  Int
  | JUMPFALSE Int				-- DAVID 
  | PRIMITIVE
  | CASE  [(GALT,Int)] (Maybe (Int,Int)) -- alt and maybe default
  | PRIM Prim

  | NOP

  | TABLESWITCH  Int Int [Int]           -- size, pad, labels             DAVID
  | LOOKUPSWITCH Int Int [(Int,Int)] Int -- size, pad, [(tag,label)] def  DAVID
  | MKIORETURN					-- for FFI, added by MW
 
{---------------- DAVID ------------------
  | MATCHCON    	-- set matchreg to constructor of value on top of stack
  | MATCHINT    	-- set matchreg to int on top of stack
  | JUMPS_T
  | JUMPTABLE Int       -- label 2 bytes
  | JUMPS_L
  | JUMPLENGTH Int Int  -- size default
  | JUMPLIST  Int Int   -- if matchreg == first int jump to label in second int
----------------- DAVID -------------------}

  | ZAP_STACK  Int
  | ZAP_ARG   Int

-- Stack
  | PUSH_CADR  Int
  | PUSH_CVAL  Int
  | PUSH_INT  Int
  | PUSH_CHAR  Int
  | PUSH_INTEGER  Integer
  | PUSH_FLOAT  Float
  | PUSH_DOUBLE  Double
  | PUSH_STRING  String
  | PUSH_ARG  Int	-- arg(1..)
  | PUSH_ZAP_ARG  Int	-- arg(1..)
  | PUSH      Int	-- stackoffset(0..)
  | PUSH_HEAP
  | PUSH_GLB  String Int

  | POP       Int	-- size
  | SLIDE     Int	-- remove
  | UNPACK    Int

-- selector functions
  | SELECTOR_EVAL	-- push the first (and only) argument and evaluate is
  | SELECT    Int       -- TOS is a constructor, replace it with it's i:th argument

-- evaluation
  | APPLY     Int	-- extra arguments on the stack (1..)
  | EVAL
  | EVALUATED	        -- message from FixGcode to GcodeOp1 that tos i evaluated

  | RETURN
  | RETURN_EVAL

-- Heap
  | HEAP_CADR  Int
  | HEAP_CVAL  Int
  | HEAP_INT  Int
  | HEAP_CHAR  Int
  | HEAP_INTEGER  Integer
  | HEAP_FLOAT  Float
  | HEAP_DOUBLE  Double
  | HEAP_STRING  String
  | HEAP_ARG  Int	-- arg(1..)
  | HEAP_ARG_ARG Int Int-- arg(1..) arg(1..)
  | HEAP_ARG_ARG_RET_EVAL Int Int-- arg(1..) arg(1..) then RETURN_EVAL
  | HEAP      Int	-- stackoffset(0..)
  | HEAP_GLB  String Int

  | HEAP_CON  Int	-- ident
  | HEAP_VAP  Int	-- ident
  | HEAP_CAP  Int Int   -- ident size
  | HEAP_OFF  Int	-- hpoffset

  | HEAP_STATIC   Int Int -- Producer Construction (Module and Type is easy to get later)
  | HEAP_CREATE         -- Initiate dynamic
  | HEAP_SPACE          -- empty word, used for retainer and enumeration fields

  | ALIGN               -- pointer
  | ALIGN_CONST         -- double
  | DATA_CREATE
  | DATA_CAPITEM Int Int -- little endian
  | DATA_CONSTHEADER Int Int
  | DATA_W  Int
  | DATA_S  String
  | DATA_F  Float
  | DATA_D  Double
  | DATA_NOP    -- does not generate anything, used after DATA_D to keep 1 DATA/WORD
  | DATA_CLABEL Int	-- call primitive C function
  | DATA_FLABEL Int	-- call foreign imported function
  | DATA_GLB String Int
  | DATA_VAP Int
  | DATA_CAP Int Int
  | DATA_CON  Int Int   -- size cno
  | DATA_CONW Int Int   -- size extra
  | DATA_CONP Int Int   -- size extra
  deriving (Eq)

showsL l s = "L_" ++ shows l s

showsR l s = shows l s

strGcode state g = strGcodePrim showsL state g
strGcodeRel state g = strGcodePrim showsR state g


strGcodePrim sL state (STARTFUN pos i) = "STARTFUN  " ++ shows i "(" ++ strIS state (toEnum i) ++ ")\n" 
strGcodePrim sL state (NEEDHEAP i) = "  NEEDHEAP " ++ shows i "\n"
strGcodePrim sL state (NEEDSTACK i) = "  NEEDSTACK " ++ shows i "\n"
strGcodePrim sL state (LABEL i)    = showsL i ":\n"
strGcodePrim sL state (LOCAL s i)    =  s++strIS state (toEnum i) ++ ":\n" 
strGcodePrim sL state (GLOBAL s i) = let str = s++strIS state (toEnum i) in "  EXPORT " ++ str ++ "\n" ++ str ++ ":\n" 
strGcodePrim sL state (JUMP  i)    = "  JUMP  " ++ sL i "\n"
strGcodePrim sL state (JUMPFALSE i)  = "  JUMPFALSE " ++ sL i "\n"
strGcodePrim sL state (PRIMITIVE)    = "  PRIMITIVE\n"

strGcodePrim sL state (PRIM prim) = "  " ++ strPrim prim ++ "\n"
strGcodePrim sL state (CASE alts def) = "  CASE\n" ++ concatMap (strGalt state) alts 
				++ (case def of
                                     Just (def,pop) -> "    _ => " ++ sL def "  (pop " ++ shows pop ")"
                                     Nothing -> "") ++ "\n"

strGcodePrim sL state (NOP) = "  NOP\n"

strGcodePrim sL state (TABLESWITCH size pad ls) =       -- DAVID
        "  TABLESWITCH " ++ show size ++ " " ++ show pad ++
        " { " ++ foldr (\i s -> sL i (' ' : s)) "}\n" ls

strGcodePrim sL state (LOOKUPSWITCH size pad tls def) = -- DAVID
        "  LOOKUPSWITCH " ++ show size ++ " " ++ show pad ++
        " { " ++ foldr (\(t,i) s -> '(' : show t ++ "," ++ sL i (") " ++ s))
                       (show def ++ "}\n") tls
strGcodePrim sL state (MKIORETURN) = "  MKIORETURN\n"	-- MW

{------------ DAVID ----------------
strGcodePrim sL state (MATCHCON) = "  MATCHCON\n"
strGcodePrim sL state (MATCHINT) = "  MATCHINT\n"
strGcodePrim sL state (JUMPS_T)  = "  JUMPS_T\n"
strGcodePrim sL state (JUMPTABLE l) = "    JUMPTABLE " ++ sL l "\n"
strGcodePrim sL state (JUMPS_L)  = "  JUMPS_L\n"
strGcodePrim sL state (JUMPLENGTH s l) = "    JUMPLENGTH " ++ shows s ( " def " ++ sL l "\n")
strGcodePrim sL state (JUMPLIST  v l)  = "    JUMPLIST    con:" ++ shows v ( " => " ++ sL l "\n")
------------ DAVID -------------- -}

strGcodePrim sL state (ZAP_STACK  i)  = "  ZAP_STACK " ++ shows i "\n"
strGcodePrim sL state (ZAP_ARG  i)   = "  ZAP_ARG " ++ shows i "\n"

-- Stack
strGcodePrim sL state (PUSH_CADR  i)   = "  PUSH_CADR " ++ shows i "\n"
strGcodePrim sL state (PUSH_CVAL  i)   = "  PUSH_CVAL " ++ shows i "\n"
strGcodePrim sL state (PUSH_INT  i)    = "  PUSH_INT " ++ shows i "\n"
strGcodePrim sL state (PUSH_CHAR  i)   = "  PUSH_CHAR " ++ shows i "\n"
strGcodePrim sL state (PUSH_STRING  i) = "  PUSH_STRING " ++ shows i "\n"
strGcodePrim sL state (PUSH_INTEGER  i)= "  PUSH_INTEGER " ++ shows i "\n"
strGcodePrim sL state (PUSH_FLOAT  i)  = "  PUSH_FLOAT " ++ shows i "\n"
strGcodePrim sL state (PUSH_DOUBLE  i) = "  PUSH_DOUBLE " ++ shows i "\n"
strGcodePrim sL state (PUSH_ARG  i)    = "  PUSH_ARG " ++ shows i "\n"
strGcodePrim sL state (PUSH_ZAP_ARG  i)    = "  PUSH_ZAP_ARG " ++ shows i "\n"
strGcodePrim sL state (PUSH      i)    = "  PUSH " ++ shows i "\n"
strGcodePrim sL state (PUSH_HEAP)      = "  PUSH_HEAP\n"
strGcodePrim sL state (PUSH_GLB  s i)  = "  PUSH_GLB " ++ s ++ strIS state (toEnum i) ++ " (" ++ shows i ")\n"
strGcodePrim sL state (POP       i)    = "  POP " ++ shows i "\n"
strGcodePrim sL state (SLIDE     i)    = "  SLIDE " ++ shows i "\n"
strGcodePrim sL state (UNPACK    i)    = "  UNPACK " ++ shows i "\n"

-- selector
strGcodePrim sL state (SELECTOR_EVAL)  = "  SELECTOR_EVAL\n"
strGcodePrim sL state (SELECT    i)    = "  SELECT " ++ shows i "\n"

-- evaluation
strGcodePrim sL state (APPLY     i) = "  APPLY " ++ shows i "\n"
strGcodePrim sL state (EVAL)        = "  EVAL\n"
strGcodePrim sL state (EVALUATED)   = "  EVALUATED\n"
strGcodePrim sL state (RETURN)      = "  RETURN\n"
strGcodePrim sL state (RETURN_EVAL) = "  RETURN_EVAL\n"

-- Heap
strGcodePrim sL state (HEAP_CADR  i)   = "  HEAP_CADR " ++ shows i "\n"
strGcodePrim sL state (HEAP_CVAL  i)   = "  HEAP_CVAL " ++ shows i "\n"
strGcodePrim sL state (HEAP_INT  i)    = "  HEAP_INT " ++ shows i "\n"
strGcodePrim sL state (HEAP_CHAR  i)   = "  HEAP_CHAR " ++ shows i "\n"
strGcodePrim sL state (HEAP_STRING  i) = "  HEAP_STRING " ++ shows i "\n"
strGcodePrim sL state (HEAP_INTEGER  i)= "  HEAP_INTEGER " ++ shows i "\n"
strGcodePrim sL state (HEAP_FLOAT  i)  = "  HEAP_FLOAT " ++ shows i "\n"
strGcodePrim sL state (HEAP_DOUBLE  i) = "  HEAP_DOUBLE " ++ shows i "\n"
strGcodePrim sL state (HEAP_ARG  i)    = "  HEAP_ARG " ++ shows i "\n"
strGcodePrim sL state (HEAP_ARG_ARG i j)="  HEAP_ARG_ARG " ++ shows i " " ++ shows j "\n"
strGcodePrim sL state (HEAP_ARG_ARG_RET_EVAL i j)="  HEAP_ARG_ARG_RET_EVAL " ++ shows i " " ++ shows j "\n"
strGcodePrim sL state (HEAP      i)    = "  HEAP " ++ shows i "\n"
strGcodePrim sL state (HEAP_GLB  s i)    = "  HEAP_GLB " ++ s ++ strIS state (toEnum i) ++ " (" ++ shows i ")\n"
strGcodePrim sL state (HEAP_CON  i)    = "  HEAP_CON " ++ shows i (" (" ++ strIS state (toEnum i) ++ ")\n")
strGcodePrim sL state (HEAP_VAP  i)    = "  HEAP_VAP " ++ shows i (" (" ++ strIS state (toEnum i) ++ ")\n")
strGcodePrim sL state (HEAP_CAP  i s)  = "  HEAP_CAP " ++ strIS state (toEnum i) ++ ":" ++ shows s (" (" ++ shows i ")\n" )
strGcodePrim sL state (HEAP_OFF  i)    = "  HEAP_OFF " ++ shows i "\n"

strGcodePrim sL state (HEAP_STATIC p c) = "  HEAP_STATIC " ++ strIS state (toEnum p) ++ " " ++ strIS state (toEnum c) ++ "\n"
strGcodePrim sL state (HEAP_CREATE)     = "  HEAP_CREATE\n"
strGcodePrim sL state (HEAP_SPACE)      = "  HEAP_SPACE\n"

strGcodePrim sL state (DATA_CREATE)     = "  DATA_CREATE\n"
strGcodePrim sL state (DATA_CAPITEM a b) = "  DATA_CAPITEM " ++ shows a (' ':shows b "\n")
strGcodePrim sL state (DATA_CONSTHEADER a b)     = "  DATA_CONSTHEADER " ++ shows a (' ':shows b "\n")
strGcodePrim sL state (DATA_W  i)       = "  DATA_W " ++ shows i "\n"
strGcodePrim sL state (DATA_F  f)       = "  DATA_F " ++ shows f "\n"
strGcodePrim sL state (DATA_S  s)       = "  DATA_S " ++ shows s "\n"
strGcodePrim sL state (DATA_D  d)       = "  DATA_D " ++ shows d "\n"
strGcodePrim sL state (DATA_NOP)        = "  DATA_NOP\n"
strGcodePrim sL state (DATA_CLABEL i)   = "  DATA_CLABEL " ++ showCLabel state i ( " (" ++ shows i ")\n")
strGcodePrim sL state (DATA_FLABEL i)   = "  DATA_FLABEL " ++ showCLabel state i ( " (" ++ shows i ")\n")
strGcodePrim sL state (DATA_GLB s i)    = "  DATA_GLB " ++ s ++ strIS state (toEnum i) ++ " (" ++ shows i ")\n"
strGcodePrim sL state (DATA_VAP i)      = "  DATA_VAP " ++ shows i "(" ++ strIS state (toEnum i) ++ ")\n" 
strGcodePrim sL state (DATA_CAP  i s)   = "  DATA_CAP " ++ strIS state (toEnum i) ++ ":" ++ shows s (" (" ++ shows i ")\n" )
strGcodePrim sL state (DATA_CON  s c)   = "  DATA_CON " ++ shows s (' ':shows c "\n")
strGcodePrim sL state (DATA_CONW s e)   = "  DATA_CONW " ++ shows s (' ':shows e "\n")
strGcodePrim sL state (DATA_CONP s e)   = "  DATA_CONP " ++ shows s (' ':shows e "\n")

strGcodePrim sL state (ALIGN) = "\n\n  ALIGN\n"
strGcodePrim sL state (ALIGN_CONST) = "\n\n  ALIGN_CONST\n"


strGalt state (GALT_CON i,l) = "    " ++ shows i " (" ++ strIS state (toEnum i) ++ ")=> " ++ showsL l "\n"  
strGalt state (GALT_INT i,l) = "    " ++ shows i " => " ++ showsL l "\n"

showCLabel state i =  shows (dropM (tidIS state (toEnum i)))