From b3f1e3ff0404a5182b6eed2d88014b4b4fbd69c2 Mon Sep 17 00:00:00 2001 From: Camil Staps Date: Fri, 1 Jul 2016 19:37:38 +0200 Subject: Moved to directory, added test program --- ABC/AStack.dcl | 18 +++ ABC/AStack.icl | 42 ++++++ ABC/Assembler.dcl | 78 +++++++++++ ABC/Assembler.icl | 122 ++++++++++++++++ ABC/BStack.dcl | 38 +++++ ABC/BStack.icl | 103 ++++++++++++++ ABC/CStack.dcl | 15 ++ ABC/CStack.icl | 26 ++++ ABC/Def.dcl | 31 +++++ ABC/Def.icl | 1 + ABC/Driver.dcl | 7 + ABC/Driver.icl | 26 ++++ ABC/GraphStore.dcl | 25 ++++ ABC/GraphStore.icl | 70 ++++++++++ ABC/IO.dcl | 17 +++ ABC/IO.icl | 30 ++++ ABC/Instructions.dcl | 64 +++++++++ ABC/Instructions.icl | 386 +++++++++++++++++++++++++++++++++++++++++++++++++++ ABC/Machine.dcl | 17 +++ ABC/Machine.icl | 1 + ABC/Misc.dcl | 8 ++ ABC/Misc.icl | 17 +++ ABC/Nodes.dcl | 27 ++++ ABC/Nodes.icl | 77 ++++++++++ ABC/Program.dcl | 13 ++ ABC/Program.icl | 30 ++++ AStack.dcl | 18 --- AStack.icl | 42 ------ Assembler.dcl | 78 ----------- Assembler.icl | 122 ---------------- BStack.dcl | 38 ----- BStack.icl | 103 -------------- CStack.dcl | 15 -- CStack.icl | 26 ---- Def.dcl | 31 ----- Def.icl | 1 - Driver.dcl | 7 - Driver.icl | 26 ---- GraphStore.dcl | 25 ---- GraphStore.icl | 70 ---------- IO.dcl | 17 --- IO.icl | 30 ---- Instructions.dcl | 64 --------- Instructions.icl | 386 --------------------------------------------------- Machine.dcl | 17 --- Machine.icl | 1 - Misc.dcl | 8 -- Misc.icl | 17 --- Nodes.dcl | 27 ---- Nodes.icl | 77 ---------- Program.dcl | 13 -- Program.icl | 30 ---- test.icl | 148 ++++++++++++++++++++ 53 files changed, 1437 insertions(+), 1289 deletions(-) create mode 100644 ABC/AStack.dcl create mode 100644 ABC/AStack.icl create mode 100644 ABC/Assembler.dcl create mode 100644 ABC/Assembler.icl create mode 100644 ABC/BStack.dcl create mode 100644 ABC/BStack.icl create mode 100644 ABC/CStack.dcl create mode 100644 ABC/CStack.icl create mode 100644 ABC/Def.dcl create mode 100644 ABC/Def.icl create mode 100644 ABC/Driver.dcl create mode 100644 ABC/Driver.icl create mode 100644 ABC/GraphStore.dcl create mode 100644 ABC/GraphStore.icl create mode 100644 ABC/IO.dcl create mode 100644 ABC/IO.icl create mode 100644 ABC/Instructions.dcl create mode 100644 ABC/Instructions.icl create mode 100644 ABC/Machine.dcl create mode 100644 ABC/Machine.icl create mode 100644 ABC/Misc.dcl create mode 100644 ABC/Misc.icl create mode 100644 ABC/Nodes.dcl create mode 100644 ABC/Nodes.icl create mode 100644 ABC/Program.dcl create mode 100644 ABC/Program.icl delete mode 100644 AStack.dcl delete mode 100644 AStack.icl delete mode 100644 Assembler.dcl delete mode 100644 Assembler.icl delete mode 100644 BStack.dcl delete mode 100644 BStack.icl delete mode 100644 CStack.dcl delete mode 100644 CStack.icl delete mode 100644 Def.dcl delete mode 100644 Def.icl delete mode 100644 Driver.dcl delete mode 100644 Driver.icl delete mode 100644 GraphStore.dcl delete mode 100644 GraphStore.icl delete mode 100644 IO.dcl delete mode 100644 IO.icl delete mode 100644 Instructions.dcl delete mode 100644 Instructions.icl delete mode 100644 Machine.dcl delete mode 100644 Machine.icl delete mode 100644 Misc.dcl delete mode 100644 Misc.icl delete mode 100644 Nodes.dcl delete mode 100644 Nodes.icl delete mode 100644 Program.dcl delete mode 100644 Program.icl create mode 100644 test.icl diff --git a/ABC/AStack.dcl b/ABC/AStack.dcl new file mode 100644 index 0000000..423b81c --- /dev/null +++ b/ABC/AStack.dcl @@ -0,0 +1,18 @@ +definition module ABC.AStack + +from StdOverloaded import class toString +from ABC.Def import ::NodeId, ::NrArgs + +:: ASrc :== Int +:: ADst :== Int +:: AStack (:== [NodeId]) + +instance toString AStack + +as_get :: ASrc AStack -> NodeId +as_init :: AStack +as_popn :: NrArgs AStack -> AStack +as_push :: NodeId AStack -> AStack +as_pushn :: [NodeId] AStack -> AStack +as_topn :: NrArgs AStack -> [NodeId] +as_update :: ADst NodeId AStack -> AStack diff --git a/ABC/AStack.icl b/ABC/AStack.icl new file mode 100644 index 0000000..0a91ecd --- /dev/null +++ b/ABC/AStack.icl @@ -0,0 +1,42 @@ +implementation module ABC.AStack + +import StdEnv + +import ABC.Def +import ABC.Misc + +:: AStack :== [NodeId] + +instance toString AStack where toString xs = "[" <++ (",", xs) <+ "]" + +as_get :: ASrc AStack -> NodeId +as_get _ [] = abortn "as_get: index too large" +as_get 0 [n:_] = n +as_get i [_:s] = as_get (i-1) s + +as_init :: AStack +as_init = [] + +as_popn :: NrArgs AStack -> AStack +as_popn 0 s = s +as_popn _ [] = abortn "as_popn: popping too many elements" +as_popn i [_:s] = as_popn (i-1) s + +as_push :: NodeId AStack -> AStack +as_push n s = [n:s] + +as_pushn :: [NodeId] AStack -> AStack +as_pushn is s = is ++ s + +as_topn :: NrArgs AStack -> [NodeId] +as_topn i s = topn [] i s +where + topn :: [NodeId] NrArgs AStack -> [NodeId] + topn ns 0 _ = ns + topn _ i [] = abortn "as_topn: taking too many elements" + topn ns i [n:s] = topn (ns ++ [n]) (i-1) s + +as_update :: ADst NodeId AStack -> AStack +as_update 0 n [_:s] = [n:s] +as_update _ _ [] = abortn "as_update: index too large" +as_update i n [m:s] = [m:as_update (i-1) n s] diff --git a/ABC/Assembler.dcl b/ABC/Assembler.dcl new file mode 100644 index 0000000..f750609 --- /dev/null +++ b/ABC/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/ABC/Assembler.icl b/ABC/Assembler.icl new file mode 100644 index 0000000..9de0708 --- /dev/null +++ b/ABC/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/ABC/BStack.dcl b/ABC/BStack.dcl new file mode 100644 index 0000000..95cf86e --- /dev/null +++ b/ABC/BStack.dcl @@ -0,0 +1,38 @@ +definition module ABC.BStack + +from StdOverloaded import class ==, class toString +from ABC.Def import ::NrArgs + +:: Basic = Int Int + | Bool Bool + +instance == Basic +instance toString Basic + +:: BSrc :== Int +:: BDst :== Int +:: BStack (:== [Basic]) + +instance toString BStack + +bs_copy :: BSrc BStack -> BStack +bs_get :: BSrc BStack -> Basic +bs_getB :: BSrc BStack -> Bool +bs_getI :: BSrc BStack -> Int +bs_init :: BStack +bs_popn :: NrArgs BStack -> BStack +bs_push :: Basic BStack -> BStack +bs_pushB :: Bool BStack -> BStack +bs_pushI :: Int BStack -> BStack +bs_update :: BDst Basic BStack -> BStack +bs_addI :: BStack -> BStack +bs_decI :: BStack -> BStack +bs_incI :: BStack -> BStack +bs_eqB :: BStack -> BStack +bs_eqI :: BStack -> BStack +bs_eqBi :: Bool BSrc BStack -> BStack +bs_eqIi :: Int BSrc BStack -> BStack +bs_gtI :: BStack -> BStack +bs_ltI :: BStack -> BStack +bs_mulI :: BStack -> BStack +bs_subI :: BStack -> BStack diff --git a/ABC/BStack.icl b/ABC/BStack.icl new file mode 100644 index 0000000..a1caafd --- /dev/null +++ b/ABC/BStack.icl @@ -0,0 +1,103 @@ +implementation module ABC.BStack + +import StdEnv + +import ABC.Def +import ABC.Misc + +instance == Basic +where + (==) (Bool b) (Bool c) = b == c + (==) (Int m) (Int n) = m == n + (==) _ _ = False + +instance toString Basic +where + toString (Bool b) = toString b + toString (Int i) = toString i + +:: BStack :== [Basic] + +instance toString BStack where toString xs = "[" <++ (",", xs) <+ "]" + +bs_copy :: BSrc BStack -> BStack +bs_copy i s = [bs_get i s:s] + +bs_get :: BSrc BStack -> Basic +bs_get _ [] = abortn "bs_get: index too large" +bs_get 0 [b:s] = b +bs_get i [_:s] = bs_get (i-1) s + +bs_getB :: BSrc BStack -> Bool +bs_getB i s = case bs_get i s of + (Bool b) = b + _ = abortn "bs_getB on non-Bool value\n" + +bs_getI :: BSrc BStack -> Int +bs_getI i s = case bs_get i s of + (Int i) = i + _ = abortn "bs_getI on non-Int value\n" + +bs_init :: BStack +bs_init = [] + +bs_popn :: NrArgs BStack -> BStack +bs_popn 0 s = s +bs_popn _ [] = abortn "bs_popn: popping too many elements" +bs_popn i [_:s] = bs_popn (i-1) s + +bs_push :: Basic BStack -> BStack +bs_push d s = [d:s] + +bs_pushB :: Bool BStack -> BStack +bs_pushB b s = [Bool b:s] + +bs_pushI :: Int BStack -> BStack +bs_pushI i s = [Int i:s] + +bs_update :: BDst Basic BStack -> BStack +bs_update 0 d [_:s] = [d:s] +bs_update _ _ [] = abortn "bs_update: index too large" +bs_update i d [e:s] = [e:bs_update (i-1) d s] + +bs_addI :: BStack -> BStack +bs_addI [Int m:Int n:s] = bs_pushI (m+n) s +bs_addI _ = abortn "bs_addI: no integers" + +bs_decI :: BStack -> BStack +bs_decI [Int n:s] = bs_pushI (n-1) s +bs_decI _ = abortn "bs_decI: no integer" + +bs_incI :: BStack -> BStack +bs_incI [Int n:s] = bs_pushI (n+1) s +bs_incI _ = abortn "bs_incI: no integer" + +bs_eqB :: BStack -> BStack +bs_eqB [Bool b:Bool c:s] = bs_pushB (b == c) s +bs_eqB _ = abortn "bs_eqB: no booleans" + +bs_eqI :: BStack -> BStack +bs_eqI [Int m:Int n:s] = bs_pushB (m == n) s +bs_eqI _ = abortn "bs_eqI: no integers" + +bs_eqBi :: Bool BSrc BStack -> BStack +bs_eqBi b i s = bs_pushB (bs_getB i s == b) s + +bs_eqIi :: Int BSrc BStack -> BStack +bs_eqIi n i s = bs_pushB (bs_getI i s == n) s + +bs_gtI :: BStack -> BStack +bs_gtI [Int m:Int n:s] = bs_pushB (m > n) s +bs_gtI _ = abortn "bs_gtI: no integers" + +bs_ltI :: BStack -> BStack +bs_ltI [Int m:Int n:s] = bs_pushB (m < n) s +bs_ltI _ = abortn "bs_ltI: no integers" + +bs_mulI :: BStack -> BStack +bs_mulI [Int m:Int n:s] = bs_pushI (m * n) s +bs_mulI _ = abortn "bs_mulI: no integers" + +bs_subI :: BStack -> BStack +bs_subI [Int m:Int n:s] = bs_pushI (m - n) s +bs_subI _ = abortn "bs_subI: no integers" diff --git a/ABC/CStack.dcl b/ABC/CStack.dcl new file mode 100644 index 0000000..31d72de --- /dev/null +++ b/ABC/CStack.dcl @@ -0,0 +1,15 @@ +definition module ABC.CStack + +from StdOverloaded import class toString +from ABC.Def import ::InstrId + +:: CSrc :== Int +:: CDst :== Int +:: CStack (:== [InstrId]) + +instance toString CStack + +cs_init :: CStack +cs_get :: CSrc CStack -> InstrId +cs_popn :: CSrc CStack -> CStack +cs_push :: InstrId CStack -> CStack diff --git a/ABC/CStack.icl b/ABC/CStack.icl new file mode 100644 index 0000000..74ca885 --- /dev/null +++ b/ABC/CStack.icl @@ -0,0 +1,26 @@ +implementation module ABC.CStack + +import StdEnv + +import ABC.Def +import ABC.Misc + +:: CStack :== [InstrId] + +instance toString CStack where toString xs = "[" <++ (",", xs) <+ "]" + +cs_init :: CStack +cs_init = [] + +cs_get :: CSrc CStack -> InstrId +cs_get _ [] = abortn "cs_get: index too large" +cs_get 0 [i:_] = i +cs_get i [_:s] = cs_get (i-1) s + +cs_popn :: CSrc CStack -> CStack +cs_popn 0 s = s +cs_popn _ [] = abortn "cs_popn: popping too many elements" +cs_popn i [_:s] = cs_popn (i-1) s + +cs_push :: InstrId CStack -> CStack +cs_push i s = [i:s] diff --git a/ABC/Def.dcl b/ABC/Def.dcl new file mode 100644 index 0000000..db2c0c0 --- /dev/null +++ b/ABC/Def.dcl @@ -0,0 +1,31 @@ +definition module ABC.Def + +from ABC.AStack import ::AStack +from ABC.BStack import ::BStack +from ABC.CStack import ::CStack +from ABC.GraphStore import ::GraphStore, ::DescStore +from ABC.Program import ::ProgramStore +from ABC.IO import ::IO + +:: State = { astack :: AStack + , bstack :: BStack + , cstack :: CStack + , graphstore :: GraphStore + , descstore :: DescStore + , pc :: InstrId + , program :: ProgramStore + , io :: IO + } + +:: NodeId :== Int +:: NrArgs :== Int +:: ArgNr :== Int +:: DescId :== Int +:: InstrId :== Int +:: Name :== String +:: Arity :== Int + +:: Instruction :== State -> State + +:: APEntry :== InstrId +:: Args :== [NodeId] diff --git a/ABC/Def.icl b/ABC/Def.icl new file mode 100644 index 0000000..81bfeee --- /dev/null +++ b/ABC/Def.icl @@ -0,0 +1 @@ +implementation module ABC.Def diff --git a/ABC/Driver.dcl b/ABC/Driver.dcl new file mode 100644 index 0000000..e5dd9f6 --- /dev/null +++ b/ABC/Driver.dcl @@ -0,0 +1,7 @@ +definition module ABC.Driver + +from ABC.Def import ::State, ::Instruction +from ABC.GraphStore import ::Desc + +boot :: ([Instruction], [Desc]) -> State +fetch_cycle :: State -> State diff --git a/ABC/Driver.icl b/ABC/Driver.icl new file mode 100644 index 0000000..aa89ae1 --- /dev/null +++ b/ABC/Driver.icl @@ -0,0 +1,26 @@ +implementation module ABC.Driver + +import StdEnv, StdDebug + +import ABC.Machine + +boot :: ([Instruction], [Desc]) -> State +boot (prog,descs) + = { astack = as_init + , bstack = bs_init + , cstack = cs_init + , graphstore = gs_init + , descstore = ds_init descs + , pc = pc_init + , program = ps_init prog + , io = io_init + } + +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 + pc` = pc_next pc + currinstr = ps_get pc program diff --git a/ABC/GraphStore.dcl b/ABC/GraphStore.dcl new file mode 100644 index 0000000..108a77e --- /dev/null +++ b/ABC/GraphStore.dcl @@ -0,0 +1,25 @@ +definition module ABC.GraphStore + +from StdOverloaded import class toString +from ABC.Def import ::Arity, ::InstrId, ::Name, ::APEntry, ::DescId, ::NodeId +from ABC.Nodes import ::Node + +:: Desc = Desc APEntry Arity Name + +d_ap_entry :: Desc -> InstrId +d_arity :: Desc -> Arity +d_name :: Desc -> String + +:: DescStore (:== [Desc]) + +ds_get :: DescId DescStore -> Desc +ds_init :: [Desc] -> DescStore + +:: GraphStore + +show_graphstore :: GraphStore DescStore -> String + +gs_get :: NodeId GraphStore -> Node +gs_init :: GraphStore +gs_newnode :: GraphStore -> (GraphStore, NodeId) +gs_update :: NodeId (Node -> Node) GraphStore -> GraphStore diff --git a/ABC/GraphStore.icl b/ABC/GraphStore.icl new file mode 100644 index 0000000..0f32994 --- /dev/null +++ b/ABC/GraphStore.icl @@ -0,0 +1,70 @@ +implementation module ABC.GraphStore + +import StdEnv + +import ABC.Machine +import ABC.Misc + +STORE_SIZE :== 1000 + +d_ap_entry :: Desc -> InstrId +d_ap_entry (Desc e _ _) = e + +d_arity :: Desc -> Arity +d_arity (Desc _ a _) = a + +d_name :: Desc -> String +d_name (Desc _ _ n) = n + +:: DescStore :== [Desc] + +ds_get :: DescId DescStore -> Desc +ds_get 0 [d:_] = d +ds_get _ [] = abortn "ds_get: index too large" +ds_get i [_:s] = ds_get (i-1) s + +ds_init :: [Desc] -> DescStore +ds_init ds = ds + +:: GraphStore = { nodes :: [Node] + , free :: Int + } + +show_graphstore :: GraphStore DescStore -> String +show_graphstore {nodes,free} ds = show_nds (free+1) nodes ds +where + show_nds :: Int [Node] [Desc] -> String + show_nds i [] ds = "" + show_nds i [n:ns] ds + = i <+ " : " <+ show_nd n ds <+ "\n" <+ show_nds (i+1) ns ds + + 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 Empty _ = "Empty" + +gs_get :: NodeId GraphStore -> Node +gs_get i {nodes,free} = get (i-free-1) nodes +where + get :: NodeId [Node] -> Node + get 0 [n:_] = n + get _ [] = abortn ("gs_get: index " <+ i <+ " too large for " <+ length nodes <+ " node(s)") + get i [_:s] = get (i-1) s + +gs_init :: GraphStore +gs_init = {nodes=[], free=STORE_SIZE} + +gs_newnode :: GraphStore -> (GraphStore, NodeId) +gs_newnode {free=0} = abortn "gs_newnode: graph store is full" +gs_newnode {nodes,free} = ({nodes=[Empty:nodes], free=free-1}, free) + +gs_update :: NodeId (Node -> Node) GraphStore -> GraphStore +gs_update i f gs=:{nodes,free} +| place <= STORE_SIZE-free = {gs & nodes=update place nodes f} +| otherwise = abortn "gs_update: nodeid nonexistant" +where + place = i - free - 1 + + update :: Int [Node] (Node -> Node) -> [Node] + update 0 [n:s] f = [f n:s] + update i [n:s] f = [n:update (i-1) s f] diff --git a/ABC/IO.dcl b/ABC/IO.dcl new file mode 100644 index 0000000..501d8cc --- /dev/null +++ b/ABC/IO.dcl @@ -0,0 +1,17 @@ +definition module ABC.IO + +from StdOverloaded import class toString + +from ABC.Nodes import ::Node +from ABC.GraphStore import ::Desc +from ABC.Def import ::State + +:: IO (:== [Char]) + +instance toString IO + +io_init :: IO +io_print :: a IO -> IO | toString a + +show_node :: Node Desc -> String +instance toString State diff --git a/ABC/IO.icl b/ABC/IO.icl new file mode 100644 index 0000000..a7cda49 --- /dev/null +++ b/ABC/IO.icl @@ -0,0 +1,30 @@ +implementation module ABC.IO + +import StdEnv + +import ABC.Machine +import ABC.Misc + +:: IO :== [Char] + +instance toString IO where toString io = {c \\ c <- io} + +io_init :: IO +io_init = [] + +io_print :: a IO -> IO | toString a +io_print x io = io ++ fromString (toString x) + +show_node :: Node Desc -> String +show_node (Basic _ _ b) _ = toString b +show_node (Node _ _ _) (Desc _ _ n) = n + +instance toString State +where + toString {astack,bstack,cstack,graphstore,descstore,pc,program,io} + = "output : " <+ io <+ "\n" <+ + "pc : " <+ pc <+ "\n" <+ + "A-stack : " <+ astack <+ "\n" <+ + "B-stack : " <+ bstack <+ "\n" <+ + "C-stack : " <+ cstack <+ "\n" <+ + "Graph :\n" <+ show_graphstore graphstore descstore diff --git a/ABC/Instructions.dcl b/ABC/Instructions.dcl new file mode 100644 index 0000000..45bd568 --- /dev/null +++ b/ABC/Instructions.dcl @@ -0,0 +1,64 @@ +definition module ABC.Instructions + +from ABC.Def import ::NrArgs, ::State, ::DescId, ::Arity, ::InstrId, ::ArgNr +from ABC.AStack import ::ASrc, ::ADst +from ABC.BStack import ::BSrc, ::BDst + +add_args :: ASrc NrArgs ADst State -> State +create :: State -> State +del_args :: ASrc NrArgs ADst State -> State +dump :: String State -> State +eq_desc :: DescId ASrc State -> State +eq_desc_arity :: DescId Arity ASrc State -> State +eq_symbol :: ASrc ASrc State -> State +eqB :: State -> State +eqB_a :: Bool ASrc State -> State +eqB_b :: Bool BSrc State -> State +eqI :: State -> State +eqI_a :: Int ASrc State -> State +eqI_b :: Int BSrc State -> State +fill :: DescId NrArgs InstrId ADst State -> State +fill_a :: ASrc ADst State -> State +fillB :: Bool ADst State -> State +fillB_b :: BSrc ADst State -> State +fillI :: Int ADst State -> State +fillI_b :: BSrc ADst State -> State +get_desc_arity :: ASrc State -> State +get_node_arity :: ASrc State -> State +halt :: State -> State +jmp :: InstrId State -> State +jmp_eval :: State -> State +jmp_false :: InstrId State -> State +jmp_true :: InstrId State -> State +jsr :: InstrId State -> State +jsr_eval :: State -> State +no_op :: State -> State +pop_a :: NrArgs State -> State +pop_b :: NrArgs State -> State +print :: String State -> State +print_symbol :: ASrc State -> State +push_a :: ASrc State -> State +push_ap_entry :: ASrc State -> State +push_arg :: ASrc Arity ArgNr State -> State +push_arg_b :: ASrc State -> State +push_args :: ASrc Arity NrArgs State -> State +push_args_b :: ASrc State -> State +push_b :: BSrc State -> State +pushB :: Bool State -> State +pushB_a :: ASrc State -> State +pushI :: Int State -> State +pushI_a :: ASrc State -> State +repl_args :: Arity NrArgs State -> State +repl_args_b :: State -> State +rtn :: State -> State +set_entry :: InstrId ADst State -> State +update_a :: ASrc ADst State -> State +update_b :: BSrc BDst State -> State + +addI :: State -> State +decI :: State -> State +gtI :: State -> State +incI :: State -> State +ltI :: State -> State +mulI :: State -> State +subI :: State -> State diff --git a/ABC/Instructions.icl b/ABC/Instructions.icl new file mode 100644 index 0000000..6317972 --- /dev/null +++ b/ABC/Instructions.icl @@ -0,0 +1,386 @@ +implementation module ABC.Instructions + +import StdEnv + +import ABC.Machine +import ABC.Misc + +int_desc :== 0 +bool_desc :== 1 +rnf_entry :== 1 + +add_args :: ASrc NrArgs ADst State -> State +add_args a_src nr_args a_dst st=:{astack,graphstore} + = {st & astack=astack`, graphstore=graphstore`} +where + astack` = as_popn nr_args astack + graphstore` = gs_update dstid (n_fill descid entry newargs) graphstore + dstid = as_get a_dst astack + srcid = as_get a_src astack + node = gs_get srcid graphstore + descid = n_descid node + entry = n_entry node + arity = n_arity node + newargs = n_args node arity ++ as_topn nr_args astack + +create :: State -> State +create st=:{astack,graphstore} + = {st & astack=astack`, graphstore=graphstore`} +where + astack` = as_push nodeid astack + (graphstore`,nodeid) = gs_newnode graphstore + +del_args :: ASrc NrArgs ADst State -> State +del_args a_src nr_args a_dst st=:{astack,graphstore} + = {st & astack=astack`, graphstore=graphstore`} +where + astack` = as_pushn newargs astack + graphstore` = gs_update dstid (n_fill descid entry newargs) graphstore + dstid = as_get a_dst astack + srcid = as_get a_src astack + node = gs_get srcid graphstore + descid = n_descid node + entry = n_entry node + newargs = n_nargs node (arity - nr_args) arity + arity = n_arity node + +dump :: String State -> State +dump s st=:{io} + = {st & io=io_print ("\n" <+ s <+ "\n" <+ st) io} + +eq_desc :: DescId ASrc State -> State +eq_desc descid a_src st=:{astack,bstack,graphstore} + = {st & bstack=bstack`} +where + bstack` = bs_pushB equal bstack + equal = n_eq_descid node descid + node = gs_get nodeid graphstore + nodeid = as_get a_src astack + +eq_desc_arity :: DescId Arity ASrc State -> State +eq_desc_arity descid arity a_src st=:{astack,bstack,graphstore} + = {st & bstack=bstack`} +where + bstack` = bs_pushB equal bstack + equal = n_eq_descid node descid && n_eq_arity node arity + node = gs_get nodeid graphstore + nodeid = as_get a_src astack + +eq_symbol :: ASrc ASrc State -> State +eq_symbol a_src1 a_src2 st=:{astack,bstack,graphstore} + = {st & bstack=bstack`} +where + bstack` = bs_pushB equal bstack + equal = n_eq_symbol node1 node2 + (node1, node2) = (gs_get id1 graphstore, gs_get id2 graphstore) + (id1, id2) = (as_get a_src1 astack, as_get a_src2 astack) + +eqB :: State -> State +eqB st=:{bstack} + = {st & bstack=bs_eqB bstack} + +eqB_a :: Bool ASrc State -> State +eqB_a b a_src st=:{astack,bstack,graphstore} + = {st & bstack=bstack`} +where + bstack` = bs_pushB equal bstack + equal = n_eq_B (gs_get nodeid graphstore) b + nodeid = as_get a_src astack + +eqB_b :: Bool BSrc State -> State +eqB_b b b_src st=:{bstack} + = {st & bstack=bs_eqBi b b_src bstack} + +eqI :: State -> State +eqI st=:{bstack} + = {st & bstack=bs_eqI bstack} + +eqI_a :: Int ASrc State -> State +eqI_a i a_src st=:{astack,bstack,graphstore} + = {st & bstack=bstack`} +where + bstack` = bs_pushB equal bstack + equal = n_eq_I (gs_get nodeid graphstore) i + nodeid = as_get a_src astack + +eqI_b :: Int BSrc State -> State +eqI_b i b_src st=:{bstack} + = {st & bstack=bs_eqIi i b_src bstack} + +fill :: DescId NrArgs InstrId ADst State -> State +fill desc nr_args entry a_dst st=:{astack,graphstore} + = {st & astack=astack`, graphstore=graphstore`} +where + astack` = as_popn nr_args astack + graphstore` = gs_update nodeid (n_fill desc entry args) graphstore + nodeid = as_get a_dst astack + args = as_topn nr_args astack + +fill_a :: ASrc ADst State -> State +fill_a a_src a_dst st=:{astack,graphstore} + = {st & graphstore=graphstore`} +where + graphstore` = gs_update nodeid_dst (n_copy node_src) graphstore + node_src = gs_get nodeid_src graphstore + nodeid_dst = as_get a_dst astack + nodeid_src = as_get a_src astack + +fillB :: Bool ADst State -> State +fillB b a_dst st=:{astack,graphstore} + = {st & graphstore=graphstore`} +where + graphstore` = gs_update nodeid (n_fillB bool_desc rnf_entry b) graphstore + nodeid = as_get a_dst astack + +fillB_b :: BSrc ADst State -> State +fillB_b b_src a_dst st=:{astack,bstack,graphstore} + = {st & graphstore=graphstore`} +where + graphstore` = gs_update nodeid (n_fillB bool_desc rnf_entry b) graphstore + b = bs_getB b_src bstack + nodeid = as_get a_dst astack + +fillI :: Int ADst State -> State +fillI i a_dst st=:{astack,graphstore} + = {st & graphstore=graphstore`} +where + graphstore` = gs_update nodeid (n_fillI int_desc rnf_entry i) graphstore + nodeid = as_get a_dst astack + +fillI_b :: BSrc ADst State -> State +fillI_b b_src a_dst st=:{astack,bstack,graphstore} + = {st & graphstore=graphstore`} +where + graphstore` = gs_update nodeid (n_fillI int_desc rnf_entry i) graphstore + i = bs_getI b_src bstack + nodeid = as_get a_dst astack + +get_desc_arity :: ASrc State -> State +get_desc_arity a_src st=:{astack,bstack,descstore,graphstore} + = {st & bstack=bstack`} +where + bstack` = bs_pushI arity bstack + arity = d_arity (ds_get descid descstore) + descid = n_descid (gs_get nodeid graphstore) + nodeid = as_get a_src astack + +get_node_arity :: ASrc State -> State +get_node_arity a_src st=:{astack,bstack,graphstore} + = {st & bstack=bstack`} +where + bstack` = bs_pushI arity bstack + arity = n_arity (gs_get nodeid graphstore) + nodeid = as_get a_src astack + +halt :: State -> State +halt st=:{pc} + = {st & pc=pc_halt pc} + +jmp :: InstrId State -> State +jmp addr st + = {st & pc=addr} + +jmp_eval :: State -> State +jmp_eval st=:{astack,graphstore} + = {st & pc=pc`} +where + pc` = n_entry (gs_get nodeid graphstore) + nodeid = as_get 0 astack + +jmp_false :: InstrId State -> State +jmp_false addr st=:{bstack,pc} + = {st & bstack=bstack`, pc=pc`} +where + pc` = if (not b) addr pc + b = bs_getB 0 bstack + bstack` = bs_popn 1 bstack + +jmp_true :: InstrId State -> State +jmp_true addr st=:{bstack,pc} + = {st & bstack=bstack`, pc=pc`} +where + pc` = if b addr pc + b = bs_getB 0 bstack + bstack` = bs_popn 1 bstack + +jsr :: InstrId State -> State +jsr addr st=:{cstack,pc} + = {st & cstack=cstack`, pc=pc`} +where + pc` = addr + cstack` = cs_push pc cstack + +jsr_eval :: State -> State +jsr_eval st=:{astack,cstack,graphstore,pc} + = {st & cstack=cstack`, pc=pc`} +where + pc` = n_entry (gs_get nodeid graphstore) + nodeid = as_get 0 astack + cstack` = cs_push pc cstack + +no_op :: State -> State +no_op st = st + +pop_a :: NrArgs State -> State +pop_a n st=:{astack} + = {st & astack=as_popn n astack} + +pop_b :: NrArgs State -> State +pop_b n st=:{bstack} + = {st & bstack=bs_popn n bstack} + +print :: String State -> State +print s st=:{io} + = {st & io=io_print s io} + +print_symbol :: ASrc State -> State +print_symbol a_src st=:{astack,descstore,graphstore,io} + = {st & io=io`} +where + io` = io_print string io + string = show_node node desc + desc = ds_get (n_descid node) descstore + node = gs_get nodeid graphstore + nodeid = as_get a_src astack + +push_a :: ASrc State -> State +push_a a_src st=:{astack} + = {st & astack=as_push (as_get a_src astack) astack} + +push_ap_entry :: ASrc State -> State +push_ap_entry a_src st=:{astack,cstack,descstore,graphstore} + = {st & cstack=cstack`} +where + cstack` = cs_push (d_ap_entry (ds_get descid descstore)) cstack + descid = n_descid (gs_get nodeid graphstore) + nodeid = as_get a_src astack + +push_arg :: ASrc Arity ArgNr State -> State +push_arg a_src arity arg_nr st=:{astack,graphstore} + = {st & astack=astack`} +where + astack` = as_push arg astack + arg = n_arg (gs_get nodeid graphstore) arg_nr arity + nodeid = as_get a_src astack + +push_arg_b :: ASrc State -> State +push_arg_b a_src st=:{astack,bstack,graphstore} + = {st & astack=astack`} +where + astack` = as_push arg astack + arg = n_arg (gs_get nodeid graphstore) arg_nr arity + nodeid = as_get a_src astack + arg_nr = bs_getI 0 bstack + arity = bs_getI 1 bstack + +push_args :: ASrc Arity NrArgs State -> State +push_args a_src arity nr_args st=:{astack,graphstore} + = {st & astack=astack`} +where + astack` = as_pushn args astack + args = n_nargs (gs_get nodeid graphstore) nr_args arity + nodeid = as_get a_src astack + +push_args_b :: ASrc State -> State +push_args_b a_src st=:{astack,bstack,graphstore} + = {st & astack=astack`} +where + astack` = as_pushn args astack + args = n_nargs (gs_get nodeid graphstore) nargs arity + nargs = bs_getI 0 bstack + nodeid = as_get a_src astack + arity = bs_getI 1 bstack + +push_b :: BSrc State -> State +push_b b_src st=:{bstack} + = {st & bstack=bs_push (bs_get b_src bstack) bstack} + +pushB :: Bool State -> State +pushB b st=:{bstack} + = {st & bstack=bs_pushB b bstack} + +pushB_a :: ASrc State -> State +pushB_a a_src st=:{astack,bstack,graphstore} + = {st & bstack=bstack`} +where + bstack` = bs_pushB b bstack + b = n_B (gs_get nodeid graphstore) + nodeid = as_get a_src astack + +pushI :: Int State -> State +pushI i st=:{bstack} + = {st & bstack=bs_pushI i bstack} + +pushI_a :: ASrc State -> State +pushI_a a_src st=:{astack,bstack,graphstore} + = {st & bstack=bstack`} +where + bstack` = bs_pushI i bstack + i = n_I (gs_get nodeid graphstore) + nodeid = as_get a_src astack + +repl_args :: Arity NrArgs State -> State +repl_args arity nr_args st=:{astack,graphstore} + = {st & astack=astack`} +where + astack` = as_pushn args (as_popn 1 astack) + args = n_nargs (gs_get nodeid graphstore) nr_args arity + nodeid = as_get 0 astack + +repl_args_b :: State -> State +repl_args_b st=:{astack,bstack,graphstore} + = {st & astack=astack`} +where + astack` = as_pushn args (as_popn 1 astack) + args = n_nargs (gs_get nodeid graphstore) nr_args arity + nodeid = as_get 0 astack + arity = bs_getI 0 bstack + nr_args = bs_getI 1 bstack + +rtn :: State -> State +rtn st=:{cstack} + = {st & cstack=cs_popn 1 cstack, pc=cs_get 0 cstack} + +set_entry :: InstrId ADst State -> State +set_entry entry a_dst st=:{astack,graphstore} + = {st & graphstore=graphstore`} +where + graphstore` = gs_update nodeid (n_setentry entry) graphstore + nodeid = as_get a_dst astack + +update_a :: ASrc ADst State -> State +update_a a_src a_dst st=:{astack} + = {st & astack=as_update a_dst (as_get a_src astack) astack} + +update_b :: BSrc BDst State -> State +update_b b_src b_dst st=:{bstack} + = {st & bstack=bs_update b_dst (bs_get b_src bstack) bstack} + + +addI :: State -> State +addI st=:{bstack} + = {st & bstack=bs_addI bstack} + +decI :: State -> State +decI st=:{bstack} + = {st & bstack=bs_decI bstack} + +gtI :: State -> State +gtI st=:{bstack} + = {st & bstack=bs_gtI bstack} + +incI :: State -> State +incI st=:{bstack} + = {st & bstack=bs_incI bstack} + +ltI :: State -> State +ltI st=:{bstack} + = {st & bstack=bs_ltI bstack} + +mulI :: State -> State +mulI st=:{bstack} + = {st & bstack=bs_mulI bstack} + +subI :: State -> State +subI st=:{bstack} + = {st & bstack=bs_subI bstack} diff --git a/ABC/Machine.dcl b/ABC/Machine.dcl new file mode 100644 index 0000000..de98de2 --- /dev/null +++ b/ABC/Machine.dcl @@ -0,0 +1,17 @@ +definition module ABC.Machine + +import + ABC.Def, + + ABC.AStack, + ABC.BStack, + ABC.CStack, + ABC.Nodes, + ABC.GraphStore, + ABC.Program, + ABC.IO, + + ABC.Instructions, + ABC.Driver, + + ABC.Assembler diff --git a/ABC/Machine.icl b/ABC/Machine.icl new file mode 100644 index 0000000..ab1acb4 --- /dev/null +++ b/ABC/Machine.icl @@ -0,0 +1 @@ +implementation module ABC.Machine diff --git a/ABC/Misc.dcl b/ABC/Misc.dcl new file mode 100644 index 0000000..3e632bf --- /dev/null +++ b/ABC/Misc.dcl @@ -0,0 +1,8 @@ +definition module ABC.Misc + +from StdOverloaded import class toString + +abortn :: String -> a + +(<+) infixl 5 :: a b -> String | toString a & toString b +(<++) infixl 5 :: a (g, [b]) -> String | toString a & toString b & toString g diff --git a/ABC/Misc.icl b/ABC/Misc.icl new file mode 100644 index 0000000..15e5b9d --- /dev/null +++ b/ABC/Misc.icl @@ -0,0 +1,17 @@ +implementation module ABC.Misc + +import StdEnv + +abortn :: String -> a +abortn s = abort (s +++ "\n") + +(<+) infixl 5 :: a b -> String | toString a & toString b +(<+) a b = toString a +++ toString b + +(<++) infixl 5 :: a (g, [b]) -> String | toString a & toString b & toString g +(<++) a (g,xs) = a <+ printersperse g xs + +printersperse :: a [b] -> String | toString a & toString b +printersperse g [] = "" +printersperse g [x] = toString x +printersperse g [x:xs] = x <+ g <++ (g, xs) diff --git a/ABC/Nodes.dcl b/ABC/Nodes.dcl new file mode 100644 index 0000000..9edd604 --- /dev/null +++ b/ABC/Nodes.dcl @@ -0,0 +1,27 @@ +definition module ABC.Nodes + +from ABC.Def import ::ArgNr, ::Arity, ::NodeId, ::InstrId, ::Args, ::DescId, ::NrArgs +from ABC.BStack import ::Basic + +:: Node = Node DescId InstrId Args + | Basic DescId InstrId Basic + | Empty + +n_arg :: Node ArgNr Arity -> NodeId +n_args :: Node Arity -> [NodeId] +n_arity :: Node -> Arity +n_B :: Node -> Bool +n_I :: Node -> Int +n_copy :: Node Node -> Node +n_descid :: Node -> DescId +n_entry :: Node -> InstrId +n_eq_arity :: Node Arity -> Bool +n_eq_B :: Node Bool -> Bool +n_eq_descid :: Node DescId -> Bool +n_eq_I :: Node Int -> Bool +n_eq_symbol :: Node Node -> Bool +n_fill :: DescId InstrId Args Node -> Node +n_fillB :: DescId InstrId Bool Node -> Node +n_fillI :: DescId InstrId Int Node -> Node +n_nargs :: Node NrArgs Arity -> [NodeId] +n_setentry :: InstrId Node -> Node diff --git a/ABC/Nodes.icl b/ABC/Nodes.icl new file mode 100644 index 0000000..fa29cb4 --- /dev/null +++ b/ABC/Nodes.icl @@ -0,0 +1,77 @@ +implementation module ABC.Nodes + +import StdEnv + +import ABC.Machine +import ABC.Misc + +n_arg :: Node ArgNr Arity -> NodeId +n_arg n i a +| a >= i = (n_args n a)!!i +| otherwise = abortn "n_arg: index greater than arity" + +n_args :: Node Arity -> [NodeId] +n_args (Node _ _ args) a +| a == length args = args +| otherwise = abortn "n_args: incorrect arity" +n_args _ _ = abortn "n_args: no arguments in node" + +n_arity :: Node -> Arity +n_arity (Basic _ _ _) = 0 +n_arity (Node _ _ args) = length args +n_arity Empty = abortn "n_arity: arity on Empty not defined" + +n_B :: Node -> Bool +n_B (Basic _ _ (Bool b)) = b +n_B _ = abortn "n_B: no boolean in node" + +n_I :: Node -> Int +n_I (Basic _ _ (Int i)) = i +n_I _ = abortn "n_I: no integer in node" + +n_copy :: Node Node -> Node +n_copy new old = new + +n_descid :: Node -> DescId +n_descid (Node i _ _) = i +n_descid (Basic i _ _) = i +n_descid Empty = abortn "n_descid: no descid in node" + +n_entry :: Node -> InstrId +n_entry (Node _ e _) = e +n_entry (Basic _ e _) = e +n_entry Empty = abortn "n_entry: no entry in node" + +n_eq_arity :: Node Arity -> Bool +n_eq_arity n a = n_arity n == a + +n_eq_B :: Node Bool -> Bool +n_eq_B n b = n_B n == b + +n_eq_descid :: Node DescId -> Bool +n_eq_descid n i = n_descid n == i + +n_eq_I :: Node Int -> Bool +n_eq_I n i = n_I n == i + +n_eq_symbol :: Node Node -> Bool +n_eq_symbol (Node i1 _ _) (Node i2 _ _) = i1 == i2 +n_eq_symbol (Basic i1 _ b1) (Basic i2 _ b2) = i1 == i2 && b1 == b2 +n_eq_symbol _ _ = False + +n_fill :: DescId InstrId Args Node -> Node +n_fill d i a _ = Node d i a + +n_fillB :: DescId InstrId Bool Node -> Node +n_fillB d e b _ = Basic d e (Bool b) + +n_fillI :: DescId InstrId Int Node -> Node +n_fillI d e i _ = Basic d e (Int i) + +n_nargs :: Node NrArgs Arity -> [NodeId] +n_nargs n i a = take i (n_args n a) + +n_setentry :: InstrId Node -> Node +n_setentry e (Node d _ a) = Node d e a +n_setentry e (Basic d _ b) = Basic d e b +n_setentry _ Empty = abortn "n_setentry: Empty node" diff --git a/ABC/Program.dcl b/ABC/Program.dcl new file mode 100644 index 0000000..ffdf948 --- /dev/null +++ b/ABC/Program.dcl @@ -0,0 +1,13 @@ +definition module ABC.Program + +from ABC.Def import ::InstrId, ::Instruction, ::State + +pc_init :: InstrId +pc_next :: InstrId -> InstrId +pc_halt :: InstrId -> InstrId +pc_end :: InstrId -> Bool + +:: ProgramStore + +ps_get :: InstrId ProgramStore -> Instruction +ps_init :: [Instruction] -> ProgramStore diff --git a/ABC/Program.icl b/ABC/Program.icl new file mode 100644 index 0000000..4a34ec6 --- /dev/null +++ b/ABC/Program.icl @@ -0,0 +1,30 @@ +implementation module ABC.Program + +import StdEnv + +import ABC.Machine +import ABC.Misc + +pc_init :: InstrId +pc_init = 0 + +pc_next :: InstrId -> InstrId +pc_next i = i + 1 + +pc_halt :: InstrId -> InstrId +pc_halt _ = -1 + +pc_end :: InstrId -> Bool +pc_end i = i < 0 + +:: Location = I Instruction +:: ProgramStore :== [Location] + +ps_get :: InstrId ProgramStore -> Instruction +ps_get 0 [I p:_] = p +ps_get _ [] = abortn "ps_get: index too large" +ps_get i [_:ps] = ps_get (i-1) ps + +ps_init :: [Instruction] -> ProgramStore +ps_init [] = [] +ps_init [i:is] = [I i:ps_init is] diff --git a/AStack.dcl b/AStack.dcl deleted file mode 100644 index 423b81c..0000000 --- a/AStack.dcl +++ /dev/null @@ -1,18 +0,0 @@ -definition module ABC.AStack - -from StdOverloaded import class toString -from ABC.Def import ::NodeId, ::NrArgs - -:: ASrc :== Int -:: ADst :== Int -:: AStack (:== [NodeId]) - -instance toString AStack - -as_get :: ASrc AStack -> NodeId -as_init :: AStack -as_popn :: NrArgs AStack -> AStack -as_push :: NodeId AStack -> AStack -as_pushn :: [NodeId] AStack -> AStack -as_topn :: NrArgs AStack -> [NodeId] -as_update :: ADst NodeId AStack -> AStack diff --git a/AStack.icl b/AStack.icl deleted file mode 100644 index 0a91ecd..0000000 --- a/AStack.icl +++ /dev/null @@ -1,42 +0,0 @@ -implementation module ABC.AStack - -import StdEnv - -import ABC.Def -import ABC.Misc - -:: AStack :== [NodeId] - -instance toString AStack where toString xs = "[" <++ (",", xs) <+ "]" - -as_get :: ASrc AStack -> NodeId -as_get _ [] = abortn "as_get: index too large" -as_get 0 [n:_] = n -as_get i [_:s] = as_get (i-1) s - -as_init :: AStack -as_init = [] - -as_popn :: NrArgs AStack -> AStack -as_popn 0 s = s -as_popn _ [] = abortn "as_popn: popping too many elements" -as_popn i [_:s] = as_popn (i-1) s - -as_push :: NodeId AStack -> AStack -as_push n s = [n:s] - -as_pushn :: [NodeId] AStack -> AStack -as_pushn is s = is ++ s - -as_topn :: NrArgs AStack -> [NodeId] -as_topn i s = topn [] i s -where - topn :: [NodeId] NrArgs AStack -> [NodeId] - topn ns 0 _ = ns - topn _ i [] = abortn "as_topn: taking too many elements" - topn ns i [n:s] = topn (ns ++ [n]) (i-1) s - -as_update :: ADst NodeId AStack -> AStack -as_update 0 n [_:s] = [n:s] -as_update _ _ [] = abortn "as_update: index too large" -as_update i n [m:s] = [m:as_update (i-1) n s] diff --git a/Assembler.dcl b/Assembler.dcl deleted file mode 100644 index f750609..0000000 --- a/Assembler.dcl +++ /dev/null @@ -1,78 +0,0 @@ -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 deleted file mode 100644 index 9de0708..0000000 --- a/Assembler.icl +++ /dev/null @@ -1,122 +0,0 @@ -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/BStack.dcl b/BStack.dcl deleted file mode 100644 index 95cf86e..0000000 --- a/BStack.dcl +++ /dev/null @@ -1,38 +0,0 @@ -definition module ABC.BStack - -from StdOverloaded import class ==, class toString -from ABC.Def import ::NrArgs - -:: Basic = Int Int - | Bool Bool - -instance == Basic -instance toString Basic - -:: BSrc :== Int -:: BDst :== Int -:: BStack (:== [Basic]) - -instance toString BStack - -bs_copy :: BSrc BStack -> BStack -bs_get :: BSrc BStack -> Basic -bs_getB :: BSrc BStack -> Bool -bs_getI :: BSrc BStack -> Int -bs_init :: BStack -bs_popn :: NrArgs BStack -> BStack -bs_push :: Basic BStack -> BStack -bs_pushB :: Bool BStack -> BStack -bs_pushI :: Int BStack -> BStack -bs_update :: BDst Basic BStack -> BStack -bs_addI :: BStack -> BStack -bs_decI :: BStack -> BStack -bs_incI :: BStack -> BStack -bs_eqB :: BStack -> BStack -bs_eqI :: BStack -> BStack -bs_eqBi :: Bool BSrc BStack -> BStack -bs_eqIi :: Int BSrc BStack -> BStack -bs_gtI :: BStack -> BStack -bs_ltI :: BStack -> BStack -bs_mulI :: BStack -> BStack -bs_subI :: BStack -> BStack diff --git a/BStack.icl b/BStack.icl deleted file mode 100644 index a1caafd..0000000 --- a/BStack.icl +++ /dev/null @@ -1,103 +0,0 @@ -implementation module ABC.BStack - -import StdEnv - -import ABC.Def -import ABC.Misc - -instance == Basic -where - (==) (Bool b) (Bool c) = b == c - (==) (Int m) (Int n) = m == n - (==) _ _ = False - -instance toString Basic -where - toString (Bool b) = toString b - toString (Int i) = toString i - -:: BStack :== [Basic] - -instance toString BStack where toString xs = "[" <++ (",", xs) <+ "]" - -bs_copy :: BSrc BStack -> BStack -bs_copy i s = [bs_get i s:s] - -bs_get :: BSrc BStack -> Basic -bs_get _ [] = abortn "bs_get: index too large" -bs_get 0 [b:s] = b -bs_get i [_:s] = bs_get (i-1) s - -bs_getB :: BSrc BStack -> Bool -bs_getB i s = case bs_get i s of - (Bool b) = b - _ = abortn "bs_getB on non-Bool value\n" - -bs_getI :: BSrc BStack -> Int -bs_getI i s = case bs_get i s of - (Int i) = i - _ = abortn "bs_getI on non-Int value\n" - -bs_init :: BStack -bs_init = [] - -bs_popn :: NrArgs BStack -> BStack -bs_popn 0 s = s -bs_popn _ [] = abortn "bs_popn: popping too many elements" -bs_popn i [_:s] = bs_popn (i-1) s - -bs_push :: Basic BStack -> BStack -bs_push d s = [d:s] - -bs_pushB :: Bool BStack -> BStack -bs_pushB b s = [Bool b:s] - -bs_pushI :: Int BStack -> BStack -bs_pushI i s = [Int i:s] - -bs_update :: BDst Basic BStack -> BStack -bs_update 0 d [_:s] = [d:s] -bs_update _ _ [] = abortn "bs_update: index too large" -bs_update i d [e:s] = [e:bs_update (i-1) d s] - -bs_addI :: BStack -> BStack -bs_addI [Int m:Int n:s] = bs_pushI (m+n) s -bs_addI _ = abortn "bs_addI: no integers" - -bs_decI :: BStack -> BStack -bs_decI [Int n:s] = bs_pushI (n-1) s -bs_decI _ = abortn "bs_decI: no integer" - -bs_incI :: BStack -> BStack -bs_incI [Int n:s] = bs_pushI (n+1) s -bs_incI _ = abortn "bs_incI: no integer" - -bs_eqB :: BStack -> BStack -bs_eqB [Bool b:Bool c:s] = bs_pushB (b == c) s -bs_eqB _ = abortn "bs_eqB: no booleans" - -bs_eqI :: BStack -> BStack -bs_eqI [Int m:Int n:s] = bs_pushB (m == n) s -bs_eqI _ = abortn "bs_eqI: no integers" - -bs_eqBi :: Bool BSrc BStack -> BStack -bs_eqBi b i s = bs_pushB (bs_getB i s == b) s - -bs_eqIi :: Int BSrc BStack -> BStack -bs_eqIi n i s = bs_pushB (bs_getI i s == n) s - -bs_gtI :: BStack -> BStack -bs_gtI [Int m:Int n:s] = bs_pushB (m > n) s -bs_gtI _ = abortn "bs_gtI: no integers" - -bs_ltI :: BStack -> BStack -bs_ltI [Int m:Int n:s] = bs_pushB (m < n) s -bs_ltI _ = abortn "bs_ltI: no integers" - -bs_mulI :: BStack -> BStack -bs_mulI [Int m:Int n:s] = bs_pushI (m * n) s -bs_mulI _ = abortn "bs_mulI: no integers" - -bs_subI :: BStack -> BStack -bs_subI [Int m:Int n:s] = bs_pushI (m - n) s -bs_subI _ = abortn "bs_subI: no integers" diff --git a/CStack.dcl b/CStack.dcl deleted file mode 100644 index 31d72de..0000000 --- a/CStack.dcl +++ /dev/null @@ -1,15 +0,0 @@ -definition module ABC.CStack - -from StdOverloaded import class toString -from ABC.Def import ::InstrId - -:: CSrc :== Int -:: CDst :== Int -:: CStack (:== [InstrId]) - -instance toString CStack - -cs_init :: CStack -cs_get :: CSrc CStack -> InstrId -cs_popn :: CSrc CStack -> CStack -cs_push :: InstrId CStack -> CStack diff --git a/CStack.icl b/CStack.icl deleted file mode 100644 index 74ca885..0000000 --- a/CStack.icl +++ /dev/null @@ -1,26 +0,0 @@ -implementation module ABC.CStack - -import StdEnv - -import ABC.Def -import ABC.Misc - -:: CStack :== [InstrId] - -instance toString CStack where toString xs = "[" <++ (",", xs) <+ "]" - -cs_init :: CStack -cs_init = [] - -cs_get :: CSrc CStack -> InstrId -cs_get _ [] = abortn "cs_get: index too large" -cs_get 0 [i:_] = i -cs_get i [_:s] = cs_get (i-1) s - -cs_popn :: CSrc CStack -> CStack -cs_popn 0 s = s -cs_popn _ [] = abortn "cs_popn: popping too many elements" -cs_popn i [_:s] = cs_popn (i-1) s - -cs_push :: InstrId CStack -> CStack -cs_push i s = [i:s] diff --git a/Def.dcl b/Def.dcl deleted file mode 100644 index db2c0c0..0000000 --- a/Def.dcl +++ /dev/null @@ -1,31 +0,0 @@ -definition module ABC.Def - -from ABC.AStack import ::AStack -from ABC.BStack import ::BStack -from ABC.CStack import ::CStack -from ABC.GraphStore import ::GraphStore, ::DescStore -from ABC.Program import ::ProgramStore -from ABC.IO import ::IO - -:: State = { astack :: AStack - , bstack :: BStack - , cstack :: CStack - , graphstore :: GraphStore - , descstore :: DescStore - , pc :: InstrId - , program :: ProgramStore - , io :: IO - } - -:: NodeId :== Int -:: NrArgs :== Int -:: ArgNr :== Int -:: DescId :== Int -:: InstrId :== Int -:: Name :== String -:: Arity :== Int - -:: Instruction :== State -> State - -:: APEntry :== InstrId -:: Args :== [NodeId] diff --git a/Def.icl b/Def.icl deleted file mode 100644 index 81bfeee..0000000 --- a/Def.icl +++ /dev/null @@ -1 +0,0 @@ -implementation module ABC.Def diff --git a/Driver.dcl b/Driver.dcl deleted file mode 100644 index e5dd9f6..0000000 --- a/Driver.dcl +++ /dev/null @@ -1,7 +0,0 @@ -definition module ABC.Driver - -from ABC.Def import ::State, ::Instruction -from ABC.GraphStore import ::Desc - -boot :: ([Instruction], [Desc]) -> State -fetch_cycle :: State -> State diff --git a/Driver.icl b/Driver.icl deleted file mode 100644 index aa89ae1..0000000 --- a/Driver.icl +++ /dev/null @@ -1,26 +0,0 @@ -implementation module ABC.Driver - -import StdEnv, StdDebug - -import ABC.Machine - -boot :: ([Instruction], [Desc]) -> State -boot (prog,descs) - = { astack = as_init - , bstack = bs_init - , cstack = cs_init - , graphstore = gs_init - , descstore = ds_init descs - , pc = pc_init - , program = ps_init prog - , io = io_init - } - -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 - pc` = pc_next pc - currinstr = ps_get pc program diff --git a/GraphStore.dcl b/GraphStore.dcl deleted file mode 100644 index 108a77e..0000000 --- a/GraphStore.dcl +++ /dev/null @@ -1,25 +0,0 @@ -definition module ABC.GraphStore - -from StdOverloaded import class toString -from ABC.Def import ::Arity, ::InstrId, ::Name, ::APEntry, ::DescId, ::NodeId -from ABC.Nodes import ::Node - -:: Desc = Desc APEntry Arity Name - -d_ap_entry :: Desc -> InstrId -d_arity :: Desc -> Arity -d_name :: Desc -> String - -:: DescStore (:== [Desc]) - -ds_get :: DescId DescStore -> Desc -ds_init :: [Desc] -> DescStore - -:: GraphStore - -show_graphstore :: GraphStore DescStore -> String - -gs_get :: NodeId GraphStore -> Node -gs_init :: GraphStore -gs_newnode :: GraphStore -> (GraphStore, NodeId) -gs_update :: NodeId (Node -> Node) GraphStore -> GraphStore diff --git a/GraphStore.icl b/GraphStore.icl deleted file mode 100644 index 0f32994..0000000 --- a/GraphStore.icl +++ /dev/null @@ -1,70 +0,0 @@ -implementation module ABC.GraphStore - -import StdEnv - -import ABC.Machine -import ABC.Misc - -STORE_SIZE :== 1000 - -d_ap_entry :: Desc -> InstrId -d_ap_entry (Desc e _ _) = e - -d_arity :: Desc -> Arity -d_arity (Desc _ a _) = a - -d_name :: Desc -> String -d_name (Desc _ _ n) = n - -:: DescStore :== [Desc] - -ds_get :: DescId DescStore -> Desc -ds_get 0 [d:_] = d -ds_get _ [] = abortn "ds_get: index too large" -ds_get i [_:s] = ds_get (i-1) s - -ds_init :: [Desc] -> DescStore -ds_init ds = ds - -:: GraphStore = { nodes :: [Node] - , free :: Int - } - -show_graphstore :: GraphStore DescStore -> String -show_graphstore {nodes,free} ds = show_nds (free+1) nodes ds -where - show_nds :: Int [Node] [Desc] -> String - show_nds i [] ds = "" - show_nds i [n:ns] ds - = i <+ " : " <+ show_nd n ds <+ "\n" <+ show_nds (i+1) ns ds - - 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 Empty _ = "Empty" - -gs_get :: NodeId GraphStore -> Node -gs_get i {nodes,free} = get (i-free-1) nodes -where - get :: NodeId [Node] -> Node - get 0 [n:_] = n - get _ [] = abortn ("gs_get: index " <+ i <+ " too large for " <+ length nodes <+ " node(s)") - get i [_:s] = get (i-1) s - -gs_init :: GraphStore -gs_init = {nodes=[], free=STORE_SIZE} - -gs_newnode :: GraphStore -> (GraphStore, NodeId) -gs_newnode {free=0} = abortn "gs_newnode: graph store is full" -gs_newnode {nodes,free} = ({nodes=[Empty:nodes], free=free-1}, free) - -gs_update :: NodeId (Node -> Node) GraphStore -> GraphStore -gs_update i f gs=:{nodes,free} -| place <= STORE_SIZE-free = {gs & nodes=update place nodes f} -| otherwise = abortn "gs_update: nodeid nonexistant" -where - place = i - free - 1 - - update :: Int [Node] (Node -> Node) -> [Node] - update 0 [n:s] f = [f n:s] - update i [n:s] f = [n:update (i-1) s f] diff --git a/IO.dcl b/IO.dcl deleted file mode 100644 index 501d8cc..0000000 --- a/IO.dcl +++ /dev/null @@ -1,17 +0,0 @@ -definition module ABC.IO - -from StdOverloaded import class toString - -from ABC.Nodes import ::Node -from ABC.GraphStore import ::Desc -from ABC.Def import ::State - -:: IO (:== [Char]) - -instance toString IO - -io_init :: IO -io_print :: a IO -> IO | toString a - -show_node :: Node Desc -> String -instance toString State diff --git a/IO.icl b/IO.icl deleted file mode 100644 index a7cda49..0000000 --- a/IO.icl +++ /dev/null @@ -1,30 +0,0 @@ -implementation module ABC.IO - -import StdEnv - -import ABC.Machine -import ABC.Misc - -:: IO :== [Char] - -instance toString IO where toString io = {c \\ c <- io} - -io_init :: IO -io_init = [] - -io_print :: a IO -> IO | toString a -io_print x io = io ++ fromString (toString x) - -show_node :: Node Desc -> String -show_node (Basic _ _ b) _ = toString b -show_node (Node _ _ _) (Desc _ _ n) = n - -instance toString State -where - toString {astack,bstack,cstack,graphstore,descstore,pc,program,io} - = "output : " <+ io <+ "\n" <+ - "pc : " <+ pc <+ "\n" <+ - "A-stack : " <+ astack <+ "\n" <+ - "B-stack : " <+ bstack <+ "\n" <+ - "C-stack : " <+ cstack <+ "\n" <+ - "Graph :\n" <+ show_graphstore graphstore descstore diff --git a/Instructions.dcl b/Instructions.dcl deleted file mode 100644 index 45bd568..0000000 --- a/Instructions.dcl +++ /dev/null @@ -1,64 +0,0 @@ -definition module ABC.Instructions - -from ABC.Def import ::NrArgs, ::State, ::DescId, ::Arity, ::InstrId, ::ArgNr -from ABC.AStack import ::ASrc, ::ADst -from ABC.BStack import ::BSrc, ::BDst - -add_args :: ASrc NrArgs ADst State -> State -create :: State -> State -del_args :: ASrc NrArgs ADst State -> State -dump :: String State -> State -eq_desc :: DescId ASrc State -> State -eq_desc_arity :: DescId Arity ASrc State -> State -eq_symbol :: ASrc ASrc State -> State -eqB :: State -> State -eqB_a :: Bool ASrc State -> State -eqB_b :: Bool BSrc State -> State -eqI :: State -> State -eqI_a :: Int ASrc State -> State -eqI_b :: Int BSrc State -> State -fill :: DescId NrArgs InstrId ADst State -> State -fill_a :: ASrc ADst State -> State -fillB :: Bool ADst State -> State -fillB_b :: BSrc ADst State -> State -fillI :: Int ADst State -> State -fillI_b :: BSrc ADst State -> State -get_desc_arity :: ASrc State -> State -get_node_arity :: ASrc State -> State -halt :: State -> State -jmp :: InstrId State -> State -jmp_eval :: State -> State -jmp_false :: InstrId State -> State -jmp_true :: InstrId State -> State -jsr :: InstrId State -> State -jsr_eval :: State -> State -no_op :: State -> State -pop_a :: NrArgs State -> State -pop_b :: NrArgs State -> State -print :: String State -> State -print_symbol :: ASrc State -> State -push_a :: ASrc State -> State -push_ap_entry :: ASrc State -> State -push_arg :: ASrc Arity ArgNr State -> State -push_arg_b :: ASrc State -> State -push_args :: ASrc Arity NrArgs State -> State -push_args_b :: ASrc State -> State -push_b :: BSrc State -> State -pushB :: Bool State -> State -pushB_a :: ASrc State -> State -pushI :: Int State -> State -pushI_a :: ASrc State -> State -repl_args :: Arity NrArgs State -> State -repl_args_b :: State -> State -rtn :: State -> State -set_entry :: InstrId ADst State -> State -update_a :: ASrc ADst State -> State -update_b :: BSrc BDst State -> State - -addI :: State -> State -decI :: State -> State -gtI :: State -> State -incI :: State -> State -ltI :: State -> State -mulI :: State -> State -subI :: State -> State diff --git a/Instructions.icl b/Instructions.icl deleted file mode 100644 index 6317972..0000000 --- a/Instructions.icl +++ /dev/null @@ -1,386 +0,0 @@ -implementation module ABC.Instructions - -import StdEnv - -import ABC.Machine -import ABC.Misc - -int_desc :== 0 -bool_desc :== 1 -rnf_entry :== 1 - -add_args :: ASrc NrArgs ADst State -> State -add_args a_src nr_args a_dst st=:{astack,graphstore} - = {st & astack=astack`, graphstore=graphstore`} -where - astack` = as_popn nr_args astack - graphstore` = gs_update dstid (n_fill descid entry newargs) graphstore - dstid = as_get a_dst astack - srcid = as_get a_src astack - node = gs_get srcid graphstore - descid = n_descid node - entry = n_entry node - arity = n_arity node - newargs = n_args node arity ++ as_topn nr_args astack - -create :: State -> State -create st=:{astack,graphstore} - = {st & astack=astack`, graphstore=graphstore`} -where - astack` = as_push nodeid astack - (graphstore`,nodeid) = gs_newnode graphstore - -del_args :: ASrc NrArgs ADst State -> State -del_args a_src nr_args a_dst st=:{astack,graphstore} - = {st & astack=astack`, graphstore=graphstore`} -where - astack` = as_pushn newargs astack - graphstore` = gs_update dstid (n_fill descid entry newargs) graphstore - dstid = as_get a_dst astack - srcid = as_get a_src astack - node = gs_get srcid graphstore - descid = n_descid node - entry = n_entry node - newargs = n_nargs node (arity - nr_args) arity - arity = n_arity node - -dump :: String State -> State -dump s st=:{io} - = {st & io=io_print ("\n" <+ s <+ "\n" <+ st) io} - -eq_desc :: DescId ASrc State -> State -eq_desc descid a_src st=:{astack,bstack,graphstore} - = {st & bstack=bstack`} -where - bstack` = bs_pushB equal bstack - equal = n_eq_descid node descid - node = gs_get nodeid graphstore - nodeid = as_get a_src astack - -eq_desc_arity :: DescId Arity ASrc State -> State -eq_desc_arity descid arity a_src st=:{astack,bstack,graphstore} - = {st & bstack=bstack`} -where - bstack` = bs_pushB equal bstack - equal = n_eq_descid node descid && n_eq_arity node arity - node = gs_get nodeid graphstore - nodeid = as_get a_src astack - -eq_symbol :: ASrc ASrc State -> State -eq_symbol a_src1 a_src2 st=:{astack,bstack,graphstore} - = {st & bstack=bstack`} -where - bstack` = bs_pushB equal bstack - equal = n_eq_symbol node1 node2 - (node1, node2) = (gs_get id1 graphstore, gs_get id2 graphstore) - (id1, id2) = (as_get a_src1 astack, as_get a_src2 astack) - -eqB :: State -> State -eqB st=:{bstack} - = {st & bstack=bs_eqB bstack} - -eqB_a :: Bool ASrc State -> State -eqB_a b a_src st=:{astack,bstack,graphstore} - = {st & bstack=bstack`} -where - bstack` = bs_pushB equal bstack - equal = n_eq_B (gs_get nodeid graphstore) b - nodeid = as_get a_src astack - -eqB_b :: Bool BSrc State -> State -eqB_b b b_src st=:{bstack} - = {st & bstack=bs_eqBi b b_src bstack} - -eqI :: State -> State -eqI st=:{bstack} - = {st & bstack=bs_eqI bstack} - -eqI_a :: Int ASrc State -> State -eqI_a i a_src st=:{astack,bstack,graphstore} - = {st & bstack=bstack`} -where - bstack` = bs_pushB equal bstack - equal = n_eq_I (gs_get nodeid graphstore) i - nodeid = as_get a_src astack - -eqI_b :: Int BSrc State -> State -eqI_b i b_src st=:{bstack} - = {st & bstack=bs_eqIi i b_src bstack} - -fill :: DescId NrArgs InstrId ADst State -> State -fill desc nr_args entry a_dst st=:{astack,graphstore} - = {st & astack=astack`, graphstore=graphstore`} -where - astack` = as_popn nr_args astack - graphstore` = gs_update nodeid (n_fill desc entry args) graphstore - nodeid = as_get a_dst astack - args = as_topn nr_args astack - -fill_a :: ASrc ADst State -> State -fill_a a_src a_dst st=:{astack,graphstore} - = {st & graphstore=graphstore`} -where - graphstore` = gs_update nodeid_dst (n_copy node_src) graphstore - node_src = gs_get nodeid_src graphstore - nodeid_dst = as_get a_dst astack - nodeid_src = as_get a_src astack - -fillB :: Bool ADst State -> State -fillB b a_dst st=:{astack,graphstore} - = {st & graphstore=graphstore`} -where - graphstore` = gs_update nodeid (n_fillB bool_desc rnf_entry b) graphstore - nodeid = as_get a_dst astack - -fillB_b :: BSrc ADst State -> State -fillB_b b_src a_dst st=:{astack,bstack,graphstore} - = {st & graphstore=graphstore`} -where - graphstore` = gs_update nodeid (n_fillB bool_desc rnf_entry b) graphstore - b = bs_getB b_src bstack - nodeid = as_get a_dst astack - -fillI :: Int ADst State -> State -fillI i a_dst st=:{astack,graphstore} - = {st & graphstore=graphstore`} -where - graphstore` = gs_update nodeid (n_fillI int_desc rnf_entry i) graphstore - nodeid = as_get a_dst astack - -fillI_b :: BSrc ADst State -> State -fillI_b b_src a_dst st=:{astack,bstack,graphstore} - = {st & graphstore=graphstore`} -where - graphstore` = gs_update nodeid (n_fillI int_desc rnf_entry i) graphstore - i = bs_getI b_src bstack - nodeid = as_get a_dst astack - -get_desc_arity :: ASrc State -> State -get_desc_arity a_src st=:{astack,bstack,descstore,graphstore} - = {st & bstack=bstack`} -where - bstack` = bs_pushI arity bstack - arity = d_arity (ds_get descid descstore) - descid = n_descid (gs_get nodeid graphstore) - nodeid = as_get a_src astack - -get_node_arity :: ASrc State -> State -get_node_arity a_src st=:{astack,bstack,graphstore} - = {st & bstack=bstack`} -where - bstack` = bs_pushI arity bstack - arity = n_arity (gs_get nodeid graphstore) - nodeid = as_get a_src astack - -halt :: State -> State -halt st=:{pc} - = {st & pc=pc_halt pc} - -jmp :: InstrId State -> State -jmp addr st - = {st & pc=addr} - -jmp_eval :: State -> State -jmp_eval st=:{astack,graphstore} - = {st & pc=pc`} -where - pc` = n_entry (gs_get nodeid graphstore) - nodeid = as_get 0 astack - -jmp_false :: InstrId State -> State -jmp_false addr st=:{bstack,pc} - = {st & bstack=bstack`, pc=pc`} -where - pc` = if (not b) addr pc - b = bs_getB 0 bstack - bstack` = bs_popn 1 bstack - -jmp_true :: InstrId State -> State -jmp_true addr st=:{bstack,pc} - = {st & bstack=bstack`, pc=pc`} -where - pc` = if b addr pc - b = bs_getB 0 bstack - bstack` = bs_popn 1 bstack - -jsr :: InstrId State -> State -jsr addr st=:{cstack,pc} - = {st & cstack=cstack`, pc=pc`} -where - pc` = addr - cstack` = cs_push pc cstack - -jsr_eval :: State -> State -jsr_eval st=:{astack,cstack,graphstore,pc} - = {st & cstack=cstack`, pc=pc`} -where - pc` = n_entry (gs_get nodeid graphstore) - nodeid = as_get 0 astack - cstack` = cs_push pc cstack - -no_op :: State -> State -no_op st = st - -pop_a :: NrArgs State -> State -pop_a n st=:{astack} - = {st & astack=as_popn n astack} - -pop_b :: NrArgs State -> State -pop_b n st=:{bstack} - = {st & bstack=bs_popn n bstack} - -print :: String State -> State -print s st=:{io} - = {st & io=io_print s io} - -print_symbol :: ASrc State -> State -print_symbol a_src st=:{astack,descstore,graphstore,io} - = {st & io=io`} -where - io` = io_print string io - string = show_node node desc - desc = ds_get (n_descid node) descstore - node = gs_get nodeid graphstore - nodeid = as_get a_src astack - -push_a :: ASrc State -> State -push_a a_src st=:{astack} - = {st & astack=as_push (as_get a_src astack) astack} - -push_ap_entry :: ASrc State -> State -push_ap_entry a_src st=:{astack,cstack,descstore,graphstore} - = {st & cstack=cstack`} -where - cstack` = cs_push (d_ap_entry (ds_get descid descstore)) cstack - descid = n_descid (gs_get nodeid graphstore) - nodeid = as_get a_src astack - -push_arg :: ASrc Arity ArgNr State -> State -push_arg a_src arity arg_nr st=:{astack,graphstore} - = {st & astack=astack`} -where - astack` = as_push arg astack - arg = n_arg (gs_get nodeid graphstore) arg_nr arity - nodeid = as_get a_src astack - -push_arg_b :: ASrc State -> State -push_arg_b a_src st=:{astack,bstack,graphstore} - = {st & astack=astack`} -where - astack` = as_push arg astack - arg = n_arg (gs_get nodeid graphstore) arg_nr arity - nodeid = as_get a_src astack - arg_nr = bs_getI 0 bstack - arity = bs_getI 1 bstack - -push_args :: ASrc Arity NrArgs State -> State -push_args a_src arity nr_args st=:{astack,graphstore} - = {st & astack=astack`} -where - astack` = as_pushn args astack - args = n_nargs (gs_get nodeid graphstore) nr_args arity - nodeid = as_get a_src astack - -push_args_b :: ASrc State -> State -push_args_b a_src st=:{astack,bstack,graphstore} - = {st & astack=astack`} -where - astack` = as_pushn args astack - args = n_nargs (gs_get nodeid graphstore) nargs arity - nargs = bs_getI 0 bstack - nodeid = as_get a_src astack - arity = bs_getI 1 bstack - -push_b :: BSrc State -> State -push_b b_src st=:{bstack} - = {st & bstack=bs_push (bs_get b_src bstack) bstack} - -pushB :: Bool State -> State -pushB b st=:{bstack} - = {st & bstack=bs_pushB b bstack} - -pushB_a :: ASrc State -> State -pushB_a a_src st=:{astack,bstack,graphstore} - = {st & bstack=bstack`} -where - bstack` = bs_pushB b bstack - b = n_B (gs_get nodeid graphstore) - nodeid = as_get a_src astack - -pushI :: Int State -> State -pushI i st=:{bstack} - = {st & bstack=bs_pushI i bstack} - -pushI_a :: ASrc State -> State -pushI_a a_src st=:{astack,bstack,graphstore} - = {st & bstack=bstack`} -where - bstack` = bs_pushI i bstack - i = n_I (gs_get nodeid graphstore) - nodeid = as_get a_src astack - -repl_args :: Arity NrArgs State -> State -repl_args arity nr_args st=:{astack,graphstore} - = {st & astack=astack`} -where - astack` = as_pushn args (as_popn 1 astack) - args = n_nargs (gs_get nodeid graphstore) nr_args arity - nodeid = as_get 0 astack - -repl_args_b :: State -> State -repl_args_b st=:{astack,bstack,graphstore} - = {st & astack=astack`} -where - astack` = as_pushn args (as_popn 1 astack) - args = n_nargs (gs_get nodeid graphstore) nr_args arity - nodeid = as_get 0 astack - arity = bs_getI 0 bstack - nr_args = bs_getI 1 bstack - -rtn :: State -> State -rtn st=:{cstack} - = {st & cstack=cs_popn 1 cstack, pc=cs_get 0 cstack} - -set_entry :: InstrId ADst State -> State -set_entry entry a_dst st=:{astack,graphstore} - = {st & graphstore=graphstore`} -where - graphstore` = gs_update nodeid (n_setentry entry) graphstore - nodeid = as_get a_dst astack - -update_a :: ASrc ADst State -> State -update_a a_src a_dst st=:{astack} - = {st & astack=as_update a_dst (as_get a_src astack) astack} - -update_b :: BSrc BDst State -> State -update_b b_src b_dst st=:{bstack} - = {st & bstack=bs_update b_dst (bs_get b_src bstack) bstack} - - -addI :: State -> State -addI st=:{bstack} - = {st & bstack=bs_addI bstack} - -decI :: State -> State -decI st=:{bstack} - = {st & bstack=bs_decI bstack} - -gtI :: State -> State -gtI st=:{bstack} - = {st & bstack=bs_gtI bstack} - -incI :: State -> State -incI st=:{bstack} - = {st & bstack=bs_incI bstack} - -ltI :: State -> State -ltI st=:{bstack} - = {st & bstack=bs_ltI bstack} - -mulI :: State -> State -mulI st=:{bstack} - = {st & bstack=bs_mulI bstack} - -subI :: State -> State -subI st=:{bstack} - = {st & bstack=bs_subI bstack} diff --git a/Machine.dcl b/Machine.dcl deleted file mode 100644 index de98de2..0000000 --- a/Machine.dcl +++ /dev/null @@ -1,17 +0,0 @@ -definition module ABC.Machine - -import - ABC.Def, - - ABC.AStack, - ABC.BStack, - ABC.CStack, - ABC.Nodes, - ABC.GraphStore, - ABC.Program, - ABC.IO, - - ABC.Instructions, - ABC.Driver, - - ABC.Assembler diff --git a/Machine.icl b/Machine.icl deleted file mode 100644 index ab1acb4..0000000 --- a/Machine.icl +++ /dev/null @@ -1 +0,0 @@ -implementation module ABC.Machine diff --git a/Misc.dcl b/Misc.dcl deleted file mode 100644 index 3e632bf..0000000 --- a/Misc.dcl +++ /dev/null @@ -1,8 +0,0 @@ -definition module ABC.Misc - -from StdOverloaded import class toString - -abortn :: String -> a - -(<+) infixl 5 :: a b -> String | toString a & toString b -(<++) infixl 5 :: a (g, [b]) -> String | toString a & toString b & toString g diff --git a/Misc.icl b/Misc.icl deleted file mode 100644 index 15e5b9d..0000000 --- a/Misc.icl +++ /dev/null @@ -1,17 +0,0 @@ -implementation module ABC.Misc - -import StdEnv - -abortn :: String -> a -abortn s = abort (s +++ "\n") - -(<+) infixl 5 :: a b -> String | toString a & toString b -(<+) a b = toString a +++ toString b - -(<++) infixl 5 :: a (g, [b]) -> String | toString a & toString b & toString g -(<++) a (g,xs) = a <+ printersperse g xs - -printersperse :: a [b] -> String | toString a & toString b -printersperse g [] = "" -printersperse g [x] = toString x -printersperse g [x:xs] = x <+ g <++ (g, xs) diff --git a/Nodes.dcl b/Nodes.dcl deleted file mode 100644 index 9edd604..0000000 --- a/Nodes.dcl +++ /dev/null @@ -1,27 +0,0 @@ -definition module ABC.Nodes - -from ABC.Def import ::ArgNr, ::Arity, ::NodeId, ::InstrId, ::Args, ::DescId, ::NrArgs -from ABC.BStack import ::Basic - -:: Node = Node DescId InstrId Args - | Basic DescId InstrId Basic - | Empty - -n_arg :: Node ArgNr Arity -> NodeId -n_args :: Node Arity -> [NodeId] -n_arity :: Node -> Arity -n_B :: Node -> Bool -n_I :: Node -> Int -n_copy :: Node Node -> Node -n_descid :: Node -> DescId -n_entry :: Node -> InstrId -n_eq_arity :: Node Arity -> Bool -n_eq_B :: Node Bool -> Bool -n_eq_descid :: Node DescId -> Bool -n_eq_I :: Node Int -> Bool -n_eq_symbol :: Node Node -> Bool -n_fill :: DescId InstrId Args Node -> Node -n_fillB :: DescId InstrId Bool Node -> Node -n_fillI :: DescId InstrId Int Node -> Node -n_nargs :: Node NrArgs Arity -> [NodeId] -n_setentry :: InstrId Node -> Node diff --git a/Nodes.icl b/Nodes.icl deleted file mode 100644 index fa29cb4..0000000 --- a/Nodes.icl +++ /dev/null @@ -1,77 +0,0 @@ -implementation module ABC.Nodes - -import StdEnv - -import ABC.Machine -import ABC.Misc - -n_arg :: Node ArgNr Arity -> NodeId -n_arg n i a -| a >= i = (n_args n a)!!i -| otherwise = abortn "n_arg: index greater than arity" - -n_args :: Node Arity -> [NodeId] -n_args (Node _ _ args) a -| a == length args = args -| otherwise = abortn "n_args: incorrect arity" -n_args _ _ = abortn "n_args: no arguments in node" - -n_arity :: Node -> Arity -n_arity (Basic _ _ _) = 0 -n_arity (Node _ _ args) = length args -n_arity Empty = abortn "n_arity: arity on Empty not defined" - -n_B :: Node -> Bool -n_B (Basic _ _ (Bool b)) = b -n_B _ = abortn "n_B: no boolean in node" - -n_I :: Node -> Int -n_I (Basic _ _ (Int i)) = i -n_I _ = abortn "n_I: no integer in node" - -n_copy :: Node Node -> Node -n_copy new old = new - -n_descid :: Node -> DescId -n_descid (Node i _ _) = i -n_descid (Basic i _ _) = i -n_descid Empty = abortn "n_descid: no descid in node" - -n_entry :: Node -> InstrId -n_entry (Node _ e _) = e -n_entry (Basic _ e _) = e -n_entry Empty = abortn "n_entry: no entry in node" - -n_eq_arity :: Node Arity -> Bool -n_eq_arity n a = n_arity n == a - -n_eq_B :: Node Bool -> Bool -n_eq_B n b = n_B n == b - -n_eq_descid :: Node DescId -> Bool -n_eq_descid n i = n_descid n == i - -n_eq_I :: Node Int -> Bool -n_eq_I n i = n_I n == i - -n_eq_symbol :: Node Node -> Bool -n_eq_symbol (Node i1 _ _) (Node i2 _ _) = i1 == i2 -n_eq_symbol (Basic i1 _ b1) (Basic i2 _ b2) = i1 == i2 && b1 == b2 -n_eq_symbol _ _ = False - -n_fill :: DescId InstrId Args Node -> Node -n_fill d i a _ = Node d i a - -n_fillB :: DescId InstrId Bool Node -> Node -n_fillB d e b _ = Basic d e (Bool b) - -n_fillI :: DescId InstrId Int Node -> Node -n_fillI d e i _ = Basic d e (Int i) - -n_nargs :: Node NrArgs Arity -> [NodeId] -n_nargs n i a = take i (n_args n a) - -n_setentry :: InstrId Node -> Node -n_setentry e (Node d _ a) = Node d e a -n_setentry e (Basic d _ b) = Basic d e b -n_setentry _ Empty = abortn "n_setentry: Empty node" diff --git a/Program.dcl b/Program.dcl deleted file mode 100644 index ffdf948..0000000 --- a/Program.dcl +++ /dev/null @@ -1,13 +0,0 @@ -definition module ABC.Program - -from ABC.Def import ::InstrId, ::Instruction, ::State - -pc_init :: InstrId -pc_next :: InstrId -> InstrId -pc_halt :: InstrId -> InstrId -pc_end :: InstrId -> Bool - -:: ProgramStore - -ps_get :: InstrId ProgramStore -> Instruction -ps_init :: [Instruction] -> ProgramStore diff --git a/Program.icl b/Program.icl deleted file mode 100644 index 4a34ec6..0000000 --- a/Program.icl +++ /dev/null @@ -1,30 +0,0 @@ -implementation module ABC.Program - -import StdEnv - -import ABC.Machine -import ABC.Misc - -pc_init :: InstrId -pc_init = 0 - -pc_next :: InstrId -> InstrId -pc_next i = i + 1 - -pc_halt :: InstrId -> InstrId -pc_halt _ = -1 - -pc_end :: InstrId -> Bool -pc_end i = i < 0 - -:: Location = I Instruction -:: ProgramStore :== [Location] - -ps_get :: InstrId ProgramStore -> Instruction -ps_get 0 [I p:_] = p -ps_get _ [] = abortn "ps_get: index too large" -ps_get i [_:ps] = ps_get (i-1) ps - -ps_init :: [Instruction] -> ProgramStore -ps_init [] = [] -ps_init [i:is] = [I i:ps_init is] diff --git a/test.icl b/test.icl new file mode 100644 index 0000000..21431bf --- /dev/null +++ b/test.icl @@ -0,0 +1,148 @@ +module test + +import StdEnv + +import ABC.Machine + +Start = toString end.io +where + (prog,descs) = assemble length + state = boot (prog,descs) + end = fetch_cycle state + +rts :: Assembler +rts + = [ Descriptor "INT" "_rnf" 0 "integer" + , Descriptor "BOOL" "_rnf" 0 "boolean" + , Jmp "init_graph" + , Label "init_graph" + , Create + , Fill "Start" 0 "n_Start" 0 + , Jsr "_driver" + , Print "\n" + , Halt + , Label "_driver" + , PushI 0 + , Label "_print" + , JsrEval + , GetNodeArity 0 + , EqI_b 0 0 + , JmpFalse "_args" + , Label "_print_last" + , PrintSymbol 0 + , Pop_a 1 + , Pop_b 1 + , Label "_brackets" + , EqI_b 0 0 + , JmpTrue "_exit" + , Print ")" + , DecI + , Jmp "_brackets" + , Label "_exit" + , Rtn + , Label "_args" + , Print "(" + , PrintSymbol 0 + , GetDescArity 0 + , ReplArgs_b + , Pop_b 1 + , Label "_arg_loop" + , Print " " + , EqI_b 1 0 + , JmpFalse "_next_arg" + , Pop_b 1 + , IncI + , Jmp "_print" + , Label "_next_arg" + , Jsr "_driver" + , DecI + , Jmp "_arg_loop" + , Label "_rnf" + , Rtn + , Label "_cycle" + , Print "cycle in spine\n" + , Halt + , Label "_type_error" + , Print "type error\n" + , Halt + ] + +ints :: Assembler +ints + = [ Label "+I1" + , IncI + , Rtn + ] + +list :: Assembler +list + = [ Descriptor "Cons" "_rnf" 2 "Cons" + , Descriptor "Nil" "_rnf" 0 "Nil" + ] + +length :: Assembler // p. 87-88 +length + = rts ++ + list ++ + ints ++ + [ Descriptor "Length" "a_Length" 2 "Length" + + , Label "n_Length" + , SetEntry "_cycle" 0 + , PushArgs 0 2 2 + + , Label "a_Length" + , Push_a 1 + , JsrEval + , Pop_a 1 + + , Label "Length1" + , EqDescArity "Cons" 2 1 + , JmpFalse "Length2" + , PushArgs 1 2 2 + , Push_a 1 + , JsrEval + , Create + , Create + , FillI 1 0 + , Push_a 5 + , Jsr "+I1" + , Update_a 1 5 + , Update_a 0 4 + , Pop_a 4 + , Jmp "Length1" + + , Label "Length2" + , EqDescArity "Nil" 0 1 + , JmpFalse "Length3" + , Fill_a 0 2 + , Pop_a 2 + , Rtn + + , Label "Length3" + , Jmp "_type_error" + + , Descriptor "Start" "n_Start" 0 "Start" + , Label "n_Start" + , Create + , Create + , Create + , Fill "Nil" 0 "_rnf" 0 + , Create + , FillI 1 0 + , Fill "Cons" 2 "_rnf" 2 + , Fill "Length" 1 "n_Length" 1 + //, Jmp "_driver" + , Dump "" + , Halt + ] + +cons_1_nil :: Assembler // p. 45, doesn't work (Nil/Cons no descriptors) +cons_1_nil + = [ Create + , Create + , Fill "Nil" 0 "_rnf" 0 + , Create + , FillI 1 0 + , Fill "Cons" 2 "_rnf" 2 + ] -- cgit v1.2.3