implementation module ABC.Assembler

import StdEnv

import ABC.Machine
import ABC.Misc

assemble :: Assembler -> ([Instruction], [Desc])
assemble stms = (translate stms loc_counter syms, descTable stms syms)
where
	loc_counter  = 0
	desc_counter = 0
	syms         = collect stms loc_counter desc_counter

:: SymType  =   LabSym | DescSym

instance == SymType
where
	(==) LabSym  LabSym  = True
	(==) DescSym DescSym = True
	(==) _       _       = False

instance toString SymType
where
	toString LabSym  = "label"
	toString DescSym = "descriptor"

:: SymTable :== [(Name, Int, SymType)]

collect :: Assembler Int Int -> SymTable
collect []                       _  _  = []
collect [Label l             :r] lc dc = [(l,lc,LabSym)  :collect r lc dc]
collect [Descriptor dl rl _ _:r] lc dc = [(dl,dc,DescSym):collect r lc (dc+1)]
collect [_                   :r] lc dc = collect r (lc+1) dc

lookup :: Label SymType SymTable -> Int
lookup l t [] = abortn ("label " <+ l <+ " not defined as " <+ t)
lookup l t [(name,n,type):r]
| l == name && t == type = n
| otherwise              = lookup l t r

descTable :: Assembler SymTable -> [Desc]
descTable []                      _    = []
descTable [Descriptor dl e a n:r] syms = [Desc ap_addr a n:descTable r syms]
where ap_addr = lookup e LabSym syms
descTable [_                  :r] syms = descTable r syms

translate :: Assembler Int SymTable -> [Instruction]
translate []                     _  _    = []
translate [Label _           :r] lc syms = translate r lc syms
translate [Descriptor _ _ _ _:r] lc syms = translate r lc syms
translate [stm               :r] lc syms
	= [trans stm lc syms:translate r (lc+1) syms]
where
	trans :: Statement Int SymTable -> Instruction
	trans (Br n)               lc _    = jmp            (lc+n+1)
	trans (BrFalse n)          lc _    = jmp_false      (lc+n+1)
	trans (BrTrue n)           lc _    = jmp_true       (lc+n+1)
	trans (Dump s)             _  _    = dump           s
	trans (AddArgs s n d)      _  _    = add_args       s n d
	trans Create               _  _    = create
	trans (DelArgs s n d)      _  _    = del_args       s n d
	trans (EqDesc dl s)        _  syms = eq_desc        daddr s
		where daddr = (lookup dl DescSym syms)
	trans (EqDescArity dl a s) _  syms = eq_desc_arity  daddr a s
		where daddr = (lookup dl DescSym syms)
	trans EqB                  _  _    = eqB
	trans (EqB_a b s)          _  _    = eqB_a b s
	trans (EqB_b b s)          _  _    = eqB_b b s
	trans EqI                  _  _    = eqI
	trans (EqI_a i s)          _  _    = eqI_a i s
	trans (EqI_b i s)          _  _    = eqI_b i s
	trans (Fill l n e d)       _  syms = fill daddr     n eaddr d
		where (daddr,eaddr) = (lookup l DescSym syms, lookup e LabSym syms)
	trans (Fill_a s d)         _  _    = fill_a s d
	trans (FillB b d)          _  _    = fillB b d
	trans (FillB_b s d)        _  _    = fillB_b s d
	trans (FillI i d)          _  _    = fillI i d
	trans (FillI_b s d)        _  _    = fillI_b s d
	trans (GetDescArity s)     _  _    = get_desc_arity s
	trans (GetNodeArity s)     _  _    = get_node_arity s
	trans Halt                 _  _    = halt
	trans (Jmp l)              _  syms = jmp            addr
		where addr = lookup l LabSym syms
	trans JmpEval              _  _    = jmp_eval
	trans (JmpFalse l)         _  syms = jmp_false      addr
		where addr = lookup l LabSym syms
	trans (JmpTrue l)          _  syms = jmp_true       addr
		where addr = lookup l LabSym syms
	trans (Jsr l)              _  syms = jsr            addr
		where addr = lookup l LabSym syms
	trans JsrEval              _  _    = jsr_eval
	trans NoOp                 _  _    = no_op
	trans (Pop_a n)            _  _    = pop_a          n
	trans (Pop_b n)            _  _    = pop_b          n
	trans (Print s)            _  _    = print          s
	trans (PrintSymbol s)      _  _    = print_symbol   s
	trans (Push_a s)           _  _    = push_a         s
	trans (PushAPEntry s)      _  _    = push_ap_entry  s
	trans (PushArg s a n)      _  _    = push_arg       s a n
	trans (PushArg_b s)        _  _    = push_arg_b     s
	trans (PushArgs s a n)     _  _    = push_args      s a n
	trans (PushArgs_b s)       _  _    = push_args_b    s
	trans (Push_b i)           _  _    = push_b         i
	trans (PushB b)            _  _    = pushB          b
	trans (PushB_a s)          _  _    = pushB_a        s
	trans (PushI i)            _  _    = pushI          i
	trans (PushI_a s)          _  _    = pushI_a        s
	trans (ReplArgs a n)       _  _    = repl_args      a n
	trans ReplArgs_b           _  _    = repl_args_b
	trans Rtn                  _  _    = rtn
	trans (SetEntry l d)       _  syms = set_entry      addr d
		where addr = lookup l LabSym syms
	trans (Update_a s d)       _  _    = update_a       s d
	trans (Update_b s d)       _  _    = update_b       s d
	trans AddI                 _  _    = addI
	trans DecI                 _  _    = decI
	trans GtI                  _  _    = gtI
	trans IncI                 _  _    = incI
	trans LtI                  _  _    = ltI
	trans MulI                 _  _    = mulI
	trans SubI                 _  _    = subI