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
|
{-
Kaya - My favourite toy language.
Copyright (C) 2004-2007 Edwin Brady
This file is distributed under the terms of the GNU General
Public Licence. See COPYING for licence.
-}
-- Ugly printer for programs, mainly to test/verify program transformations
-- are being done correctly.
module ProgramDump where
import Language
dumpall :: Program -> String
dumpall [] = ""
dumpall ((FunBind (_,_,n,Fn _ _ ty,_,(Defined fn)) _ _):fs) =
show ty ++ " " ++ showuser n ++dump fn ++ "\n\n" ++ dumpall fs
dumpall (_:fs) = dumpall fs
dump :: Expr Name -> String
dump exp = di [] 0 exp
-- Dump with indentation, and a list of variable names so that locals
-- are rendered correctly. No attempt is made to reduce use of brackets in
-- expressions, this is an ugly printer after all.
indent i = concat (take i (repeat " "))
showparams [] = ""
showparams [(n,ty)] = show ty ++ " " ++ showuser n
showparams ((n,ty):xs) = show ty ++ " " ++ showuser n ++ ", " ++ showparams xs
diargs env ind [] = ""
diargs env ind [x] = di env ind x
diargs env ind (x:xs) = di env ind x ++ ", " ++ diargs env ind xs
di :: [Name] -> Int -> Expr Name -> String
di env ind (Global n _ _) = showuser n
di env ind (Loc i) = if (length env)>i
then showuser (env!!i)
else "{VAR"++show i++"}"
di env ind (GVar i) = "global"++show i -- bah, we don't cache the names
di env ind (GConst c) = show c
di env ind (Lambda _ ns exp) = " (" ++ showparams ns ++ ") {\n" ++
di (env ++ (map fst ns)) (ind+1) exp ++
"\n" ++ indent ind ++ "}"
di env ind (Closure ns _ exp) = "\\(" ++ showparams ns ++ ") {\n" ++
di (env ++ (map fst ns)) (ind+1) exp ++
"\n" ++ indent ind ++ "}"
di env ind (Bind nm ty v exp) = indent ind ++ show ty ++ " " ++ showuser nm ++
" = " ++ di env 0 v ++ ";\n" ++
indent ind ++ di (env++[nm]) ind exp
++ "\n"
di env ind (Declare _ _ (n,_) ty exp) = indent ind ++ show ty ++ " " ++ showuser n
++ ";\n" ++
di (env++[n]) ind exp
di env ind (Return exp) = indent ind ++ "return " ++ di env 0 exp ++ ";\n"
di env ind VoidReturn = indent ind ++ "return;\n"
di env ind (Assign a exp) = indent ind ++ diass env a ++ " = " ++
di env 0 exp ++ ";\n"
di env ind (AssignOp op a exp) = indent ind ++ diass env a ++ " " ++ show op
++ "= " ++
di env 0 exp ++ ";\n"
di env ind (AssignApp a exp) = indent ind ++ diass env a ++ " += " ++
di env 0 exp ++ ";\n"
di env ind (Seq x y) = di env ind x ++ di env ind y
di env ind (Apply f as) = indent ind ++
di env ind f ++ "(" ++ diargs env 0 as ++ ")"
di env ind (ConApply f as) = indent ind ++
di env ind f ++ "(" ++ diargs env 0 as ++ ")"
di env ind (Partial _ f as _) = indent ind ++
di env ind f ++ "@(" ++ diargs env 0 as ++ ")"
di env ind (Foreign ty n as) = indent ind ++ "foreign " ++ show ty ++ " " ++
showuser n ++ "(" ++
diargs env 0 (map fst as) ++ ")"
di env ind (While c body) = indent ind ++ "while(" ++ di env 0 c ++ ") {\n" ++
di env (ind+1) body ++ "}\n"
di env ind (DoWhile c body)
= indent ind ++ "do {" ++ di env (ind+1) body ++ "} while ("
++ di env 0 c ++ ")\n"
di env ind (For i idx v val ran body)
= indent ind ++ "for " ++ showcount idx ++ diass env val ++ " in " ++
di env 0 ran ++ " {\n" ++
di env (ind+1) body ++ "}\n"
where showcount Nothing = ""
showcount (Just i) = showuser i ++ "@"
di env ind (NewTryCatch e cs) = indent ind ++ "try {\n" ++
di env (ind+1) e ++ "\n" ++
indent ind ++ "}\n" ++
concat (map (dicatch env ind) cs)
where dicatch env ind (Catch (Left (n, args)) h)
= indent ind ++
"catch(" ++ showuser n ++ "(" ++ diargs env 0 args ++ ")) {\n"
++ di env (ind+1) h ++ "\n" ++ indent ind ++ "}\n"
dicatch env ind (Catch (Right v) h)
= indent ind ++
"catch(" ++ di env 0 v ++ ") {\n"
++ di env (ind+1) h ++ "\n" ++ indent ind ++ "}\n"
di env ind (Throw exp) = indent ind ++ "throw " ++ di env 0 exp ++ ";\n"
di env ind (Break _ _) = indent ind ++ "break;\n"
di env ind (Infix op l r)
= "(" ++ di env 0 l ++ " " ++ show op ++ " " ++ di env 0 r ++ ")"
di env ind (RealInfix op l r)
= "(" ++ di env 0 l ++ " " ++ show op ++ " " ++ di env 0 r ++ ")"
di env ind (CmpExcept op l r)
= "(" ++ di env 0 l ++ " " ++ show op ++ " " ++ di env 0 r ++ ")"
di env ind (CmpStr op l r)
= "(" ++ di env 0 l ++ " " ++ show op ++ " " ++ di env 0 r ++ ")"
di env ind (Append l r)
= "(" ++ di env 0 l ++ " + " ++ di env 0 r ++ ")"
di env ind (AppendChain es)
= "(" ++ showapp es ++ ")"
where showapp [] = ""
showapp [x] = di env 0 x
showapp (x:xs) = di env 0 x ++ " + " ++ showapp xs
di env ind (Unary op e) = show op ++ di env 0 e
di env ind (RealUnary op e) = show op ++ di env 0 e
di env ind (Coerce _ ty e) = show ty ++ "(" ++ di env 0 e ++ ")"
di env ind (Case e alts)
= indent ind ++ "case " ++ di env 0 e ++ " of {\n"
++ showalts alts
++ "\n" ++ indent ind ++ "}\n"
where showalts [] = ""
showalts [x] = dialt env x
showalts (x:xs) = dialt env x ++ " |\n" ++
showalts xs
dialt env (Alt tag _ args res) = indent (ind+1) ++
"tag" ++ show tag ++ "(" ++
diargs env 0 args ++ ") -> \n" ++
di env (ind+2) res
dialt env (ConstAlt _ c res) = indent (ind+1) ++
show c ++ " -> \n" ++
di env (ind+2) res
dialt env (ArrayAlt es res) = indent (ind+1) ++
"[" ++ diargs env 0 es ++ "] -> \n" ++
di env (ind+2) res
dialt env (Default res) = indent (ind+1) ++
"default -> \n" ++ di env (ind+2) res
di env ind (If a t e)
= indent ind ++ "if (" ++ di env 0 a ++ ") {\n" ++
di env (ind+1) t ++
indent ind ++ "} else {\n" ++
di env (ind+1) e ++
indent ind ++ "}"
di env ind (Index a e) = di env ind a ++ "[" ++ di env 0 e ++ "]"
di env ind (Field e n _ _) = di env ind e ++ "." ++ showuser n
di env ind (ArrayInit es) = "[" ++ diargs env 0 es ++ "]"
di env ind VMPtr = "%vm"
di env ind (Length e) = "%length(" ++ di env 0 e ++ ")"
di env ind (Noop) = indent ind ++ "pass;\n"
di env ind (Annotation _ e) = di env ind e
di env ind NoInit = "\n NOINIT"
di env ind x = error $ show x
diass env (AName i) = if (length env)>i
then showuser (env!!i)
else "{VAR"++show i++"}"
diass env (AGlob i) = "global"++show i
diass env (AIndex a e) = diass env a ++ "[" ++ di env 0 e ++ "]"
diass env (AField a n _ _) = diass env a ++ "." ++ showuser n
|
