1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
implementation module ABC.Assembler
import StdEnv
import StdGeneric
import ABC.Machine
import ABC.Misc
instance toString Assembler
where
toString [] = ""
toString [stm=:(Label l):r] = stm <+ "\r\n" <+ r
toString [stm=:(Descriptor _ _ _ _):r] = toString r
toString [stm :r] = "\t" <+ stm <+ "\r\n" <+ r
instance <<< Assembler
where
<<< f [ ] = f
<<< f [stm=:(Label _) :r] = f <<< stm <<< "\r\n" <<< r
<<< f [stm=:(Descriptor _ _ _ _):r] = f <<< r
<<< f [stm=:(Annotation _) :r] = f <<< stm <<< "\r\n" <<< r
<<< f [stm=:(Raw _) :r] = f <<< stm <<< "\r\n" <<< r
<<< f [stm :r] = f <<< "\t" <<< stm <<< "\r\n" <<< r
instance <<< Statement where <<< f st = f <<< toString st
generic gPrint a :: !a -> [Char]
gPrint{|Int|} x = fromString (toString x)
gPrint{|Bool|} x = map toLower (fromString (toString x))
gPrint{|String|} x = fromString x
gPrint{|Annotation|} x = fromString (printAnnot x)
where
printAnnot :: Annotation -> String
printAnnot (DAnnot a bs) = ".d " <+ a <+ " " <+ length bs <+ " " <+ types bs
printAnnot (OAnnot a bs) = ".o " <+ a <+ " " <+ length bs <+ " " <+ types bs
printAnnot (RawAnnot s) = foldl (+++) "." (intersperse " " s)
where
intersperse g [] = []
intersperse g [x] = [x]
intersperse g [x:xs] = [x:g:intersperse g xs]
types :: ([BasicType] -> [Char])
types = map toC
where
toC BT_Bool = 'b'
toC BT_Int = 'i'
gPrint{|UNIT|} x = []
gPrint{|EITHER|} fl fr (LEFT x) = fl x
gPrint{|EITHER|} fl fr (RIGHT x) = fr x
gPrint{|PAIR|} fl fr (PAIR x y) = fl x ++ ['\t':fr y]
gPrint{|OBJECT|} fx (OBJECT x) = fx x
gPrint{|CONS of d|} fx (CONS x) = case d.gcd_name of
"Label" = fx x
"Descriptor" = []
"Dump" = ['dump\t"'] ++ quote (fx x) ++ ['"']
"Print" = ['print\t"'] ++ quote (fx x) ++ ['"']
"Comment" = ['| '] ++ fx x
"Annotation" = fx x
"Raw" = fx x
name = tl (cons (fromString name)) ++ ['\t':fx x]
where
cons :: ![Char] -> [Char]
cons [] = []
cons [c:cs]
| isUpper c
| isMember c ['IB'] && isEmpty cs = [c]
| isMember c ['IB'] && hd cs == '_' = [c :cons cs]
| otherwise = ['_':toLower c:cons cs]
| otherwise = [c :cons cs]
derive gPrint Statement
instance toString Statement
where
toString stm = toString (gPrint{|*|} stm)
quote :: ![Char] -> [Char]
quote [] = []
quote ['\\':cs] = ['\\':'\\':quote cs]
quote ['\n':cs] = ['\\':'n' :quote cs]
quote ['"' :cs] = ['\\':'"' :quote cs]
quote [c :cs] = [c :quote cs]
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 _ _ _: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 (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 [Comment _ :r] lc syms = translate r lc syms
translate [Annotation _ :r] lc syms = translate r lc syms
translate [Raw _ :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 DivI _ _ = divI
trans GtI _ _ = gtI
trans IncI _ _ = incI
trans LtI _ _ = ltI
trans MulI _ _ = mulI
trans RemI _ _ = remI
trans SubI _ _ = subI
|
