2 --(module M0ld.AST,dumpToC,parseM0ld) where
5 import qualified Data
.Map
as Map
7 prettyPrintBytecode indent stmts
=
8 let labelsMap
= mapLabels stmts
9 regMap
= mapRegisters stmts
10 freeRegs
= countRegister stmts
11 prettyPrintOp
(Decl _ _
) = ""
12 prettyPrintOp op
= indent
++ (joinStr
" " $ ( map show (toBytecode op regMap labelsMap
))) ++ "\n"
13 decls
= [prettyPrintConstant indent c | Decl reg c
<- filter (not . isReg
) stmts
]
14 in (concat $ map (\(i
,e
) -> indent
++ "$" ++ (show i
) ++ " = " ++ e
) (zip [0..(length decls
- 1)] decls
))
15 ++ (concat $ map prettyPrintOp stmts
)
17 type RegMap
= Map
.Map
[Char] Int
19 type LabelsMap
= Map
.Map
[Char] Int
21 resolveReg r regs
= Map
.findWithDefault
(error $ "undeclared register: $"++r
) r regs
23 resolveLabelDef l labels
= Map
.findWithDefault
(error $ "undeclared label: "++l
) l labels
25 toBytecode
:: Stmt
-> RegMap
-> LabelsMap
-> [Int]
26 toBytecode stmt regs labels
= case stmt
of
27 Call target identifier
(Capture invocant positional named
) ->
28 let reg r
= resolveReg r regs
29 args x
= [length x
] ++ map reg x
30 in [1,reg target
,reg invocant
,reg identifier
] ++ args positional
++ args named
32 Call2 target responder identifier capture
->
33 map (\r -> resolveReg r regs
) [target
,responder
,identifier
,capture
]
35 Goto label
-> [3, resolveLabelDef label labels
]
37 Br
value iftrue iffalse
->
38 [4,resolveReg
value regs
,resolveLabelDef iftrue labels
,resolveLabelDef iffalse labels
]
44 isReg
(Decl _ None
) = True
47 countRegister stmts
= length $ filter isReg stmts
49 addRegister
:: RegMap
-> Stmt
-> RegMap
50 addRegister regs stmt
= case stmt
of
52 Decl reg
value -> if (Map
.member reg regs
) then regs
else Map
.insert reg
(Map
.size regs
) regs
55 addFreeRegister
:: RegMap
-> Stmt
-> RegMap
56 addFreeRegister regs stmt
= case stmt
of
57 Decl reg None
-> if (Map
.member reg regs
) then regs
else Map
.insert reg
(Map
.size regs
) regs
61 mapRegisters
:: [Stmt
] -> RegMap
62 mapRegisters stmts
= foldl addFreeRegister
(foldl addRegister Map
.empty stmts
) stmts
64 bytecodeLength
:: Stmt
-> Int
65 bytecodeLength stmt
= case stmt
of
68 Call target identifier
(Capture invocant positional named
) ->
69 6 + length positional
+ length named
74 addLabelDef
(labels
,offset
) (LabelDef label
) = (Map
.insert label offset labels
,offset
)
75 addLabelDef
(labels
,offset
) stmt
= (labels
,offset
+bytecodeLength stmt
)
77 mapLabels
:: [Stmt
] -> LabelsMap
78 mapLabels stmts
= fst $ foldl addLabelDef
(Map
.empty,0) stmts
80 emit
:: [Stmt
] -> RegMap
-> LabelsMap
-> [Int]
81 emit stmts regMap labelsMap
= concatMap (\op
-> toBytecode op regMap labelsMap
) stmts
++ [0]
84 joinStr sep
list = foldl (\a b
-> a
++ sep
++ b
) (head list) (tail list)
86 cStrLength
('\\':next:rest
) = 1 + cStrLength rest
87 cStrLength
(c
:rest
) = 1 + cStrLength rest
90 dumpConstantToC
:: Value
-> [Char]
91 dumpConstantToC
value = case value of
93 "SMOP__NATIVE__idconst_createn(\"" ++ str
++"\"," ++ (show $ cStrLength str
) ++ "),"
94 IntegerConstant int
-> "SMOP__NATIVE__int_create(" ++ show int
++ "),"
96 Var name
-> "SMOP_REFERENCE(interpreter," ++ name
++ "),"
97 SubMold stmts
-> dumpToC stmts
++ ","
99 dumpConstantsToC stmts
= "(SMOP__Object*[]) {" ++
100 concat [dumpConstantToC c | Decl reg c
<- stmts
] ++ "NULL}"
103 let labelsMap
= mapLabels stmts
104 regMap
= mapRegisters stmts
105 freeRegs
= countRegister stmts
106 bytecode
= emit stmts regMap labelsMap
107 constants
= dumpConstantsToC stmts
108 in "SMOP__Mold_create(" ++ show freeRegs
++ "," ++ constants
++ ","
109 ++ show (length bytecode
) ++ ",(int[]) {"
110 ++ (joinStr
"," $ map show bytecode
)
113 prettyPrintConstant
:: [Char] -> Value
-> [Char]
114 prettyPrintConstant indent
value = case value of
115 StringConstant str
-> (show str
) ++ "\n"
116 IntegerConstant int
-> (show int
) ++ "\n"
118 Var name
-> "ยข" ++ name
++ "\n"
119 SubMold stmts
-> "{\n" ++ (prettyPrintBytecode
(" " ++ indent
) stmts
) ++ indent
++ "}\n"