65 lines
1.9 KiB
Haskell
65 lines
1.9 KiB
Haskell
module Compiler where
|
|
|
|
import Data.Char (isUpper)
|
|
import Data.Containers.ListUtils (nubOrd)
|
|
import Data.List
|
|
import qualified Data.Map as M
|
|
|
|
import Code (Code, Datum(..), Instr(..))
|
|
import IR (Id(..), PrlgInt(..), PrlgStr(..), StrTable(..), strtablize)
|
|
|
|
internPrlg :: StrTable -> PrlgStr -> (StrTable, PrlgInt)
|
|
internPrlg = go
|
|
where
|
|
go t (LiteralS str) = LiteralI <$> strtablize t str
|
|
go t (CallS str ps) =
|
|
let (t', i) = strtablize t str
|
|
in CallI (Id i $ length ps) <$> mapAccumL go t' ps
|
|
|
|
varname :: String -> Bool
|
|
varname ('_':_) = True
|
|
varname (c:_) = isUpper c
|
|
varname _ = False
|
|
|
|
varIds :: StrTable -> PrlgInt -> [Int]
|
|
varIds st (CallI _ xs) = nubOrd $ concatMap (varIds st) xs
|
|
varIds (StrTable _ _ st) (LiteralI x)
|
|
| Just s <- st M.!? x
|
|
, varname s = [x]
|
|
| otherwise = []
|
|
|
|
variablizePrlg :: Int -> [Int] -> PrlgInt -> PrlgInt
|
|
variablizePrlg void vs (CallI id ps) =
|
|
CallI id $ map (variablizePrlg void vs) ps
|
|
variablizePrlg void vs (LiteralI i)
|
|
| i == void = VoidI
|
|
| Just idx <- elemIndex i vs = VarI idx i
|
|
| otherwise = LiteralI i
|
|
|
|
compileGoals :: Id -> Int -> PrlgInt -> [Code]
|
|
compileGoals andop cut = go
|
|
where
|
|
go p@(CallI x args)
|
|
| x == andop = concatMap go args
|
|
go p@(LiteralI x)
|
|
| x == cut = [[Cut]]
|
|
go x = [compileGoal x]
|
|
|
|
compileGoal :: PrlgInt -> Code
|
|
compileGoal (LiteralI x) = [U (Struct $ Id x 0)]
|
|
compileGoal x = compileArg x
|
|
|
|
compileArg :: PrlgInt -> Code
|
|
compileArg (CallI x args) = U (Struct x) : concatMap compileArg args
|
|
compileArg (LiteralI x) = [U (Atom x)]
|
|
compileArg (VarI x i) = [U (LocalRef x i)]
|
|
compileArg (VoidI) = [U VoidRef]
|
|
|
|
seqGoals :: [Code] -> Code
|
|
seqGoals [] = [NoGoal]
|
|
seqGoals [[Cut]] = [Cut, NoGoal]
|
|
seqGoals [x] = [Goal] ++ x ++ [LastCall]
|
|
seqGoals [x, [Cut]] = [Goal] ++ x ++ [LastCall, Cut]
|
|
seqGoals ([Cut]:xs) = [Cut] ++ seqGoals xs
|
|
seqGoals (x:xs) = [Goal] ++ x ++ [Call] ++ seqGoals xs
|