Assembler

5 files changed, 208 insertions, 5 deletions

diff --git a/Assembler.dcl b/Assembler.dcl
new file mode 100644
index 0000000..f750609
--- /dev/null
+++ b/Assembler.dcl
@@ -0,0 +1,78 @@
+definition module ABC.Assembler
+
+from ABC.Def import ::Arity, ::Name, ::NrArgs, ::ArgNr, ::Instruction, ::State
+from ABC.AStack import ::ASrc, ::ADst
+from ABC.BStack import ::BSrc, ::BDst
+from ABC.GraphStore import ::Desc
+
+:: Label     :== String
+:: RedLabel  :== Label
+:: DescLabel :== Label
+:: NrInstr   :== Int
+
+:: Assembler :== [Statement]
+
+:: Statement
+	= Label        Label
+	| Descriptor   DescLabel RedLabel Arity Name
+	| Br           NrInstr
+	| BrFalse      NrInstr
+	| BrTrue       NrInstr
+	| Dump         String
+	| AddArgs      ASrc NrArgs ADst
+	| Create
+	| DelArgs      ASrc NrArgs ADst
+	| EqDesc       DescLabel ASrc
+	| EqDescArity  DescLabel Arity ASrc
+	| EqB
+	| EqB_a        Bool ASrc
+	| EqB_b        Bool BSrc
+	| EqI
+	| EqI_a        Int ASrc
+	| EqI_b        Int BSrc
+	| Fill         DescLabel NrArgs Label ADst
+	| Fill_a       ASrc ADst
+	| FillB        Bool ADst
+	| FillB_b      BSrc ADst
+	| FillI        Int ADst
+	| FillI_b      BSrc ADst
+	| GetDescArity ASrc
+	| GetNodeArity ASrc
+	| Halt
+	| Jmp          Label
+	| JmpEval
+	| JmpFalse     Label
+	| JmpTrue      Label
+	| Jsr          Label
+	| JsrEval
+	| NoOp
+	| Pop_a        Int
+	| Pop_b        Int
+	| Print        String
+	| PrintSymbol  ASrc
+	| Push_a       ASrc
+	| PushAPEntry  ASrc
+	| PushArg      ASrc Arity ArgNr
+	| PushArg_b    ASrc
+	| PushArgs     ASrc Arity ArgNr
+	| PushArgs_b   ASrc
+	| Push_b       Int
+	| PushB        Bool
+	| PushB_a      ASrc
+	| PushI        Int
+	| PushI_a      ASrc
+	| ReplArgs     Arity NrArgs
+	| ReplArgs_b
+	| Rtn
+	| SetEntry     Label ADst
+	| Update_a     ASrc ADst
+	| Update_b     BSrc BDst
+	| AddI
+	| DecI
+	| GtI 
+	| IncI
+	| LtI
+	| MulI
+	| SubI
+
+assemble :: Assembler -> ([Instruction], [Desc])
diff --git a/Assembler.icl b/Assembler.icl
new file mode 100644
index 0000000..9de0708
--- /dev/null
+++ b/Assembler.icl
@@ -0,0 +1,122 @@
+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
diff --git a/Driver.icl b/Driver.icl
index 633d248..aa89ae1 100644
--- a/Driver.icl
+++ b/Driver.icl
@@ -1,6 +1,6 @@
 implementation module ABC.Driver
 
-import StdEnv
+import StdEnv, StdDebug
 
 import ABC.Machine
 
@@ -18,6 +18,7 @@ boot (prog,descs)
 
 fetch_cycle :: State -> State
 fetch_cycle st=:{pc,program}
+//# pc = trace_n pc pc
 | pc_end pc = st
 | otherwise = fetch_cycle (currinstr {st & pc=pc`})
 where
diff --git a/GraphStore.icl b/GraphStore.icl
index 6f2a2e0..0f32994 100644
--- a/GraphStore.icl
+++ b/GraphStore.icl
@@ -40,15 +40,15 @@ where
 
 	show_nd :: Node [Desc] -> String
 	show_nd (Basic _ e b) _  = e <+ " " <+ b
-	show_nd (Node d e a)  ds = d_name (ds_get d ds) <+ " " <+ e <+ " " <+ a
+	show_nd (Node d e a)  ds = d_name (ds_get d ds) <+ " " <+ e <+ " [" <++ (",", a) <+ "]"
 	show_nd Empty         _  = "Empty"
 
 gs_get     :: NodeId GraphStore -> Node
-gs_get i {nodes} = get i nodes
+gs_get i {nodes,free} = get (i-free-1) nodes
 where
 	get :: NodeId [Node] -> Node
 	get 0 [n:_] = n
-	get _ []    = abortn "gs_get: index too large"
+	get _ []    = abortn ("gs_get: index " <+ i <+ " too large for " <+ length nodes <+ " node(s)")
 	get i [_:s] = get (i-1) s
 
 gs_init    :: GraphStore
diff --git a/Machine.dcl b/Machine.dcl
index e71147b..de98de2 100644
--- a/Machine.dcl
+++ b/Machine.dcl
@@ -12,4 +12,6 @@ import
 	ABC.IO,
 
 	ABC.Instructions,
-	ABC.Driver
+	ABC.Driver,
+
+	ABC.Assembler