module Language.PIR (
module Language.PIR,
module Language.PIR.Emit,
) where
import Data.Char
import Data.List
import Data.Typeable
import DrIFT.YAML
import Text.PrettyPrint
import Language.PIR.Emit
import Data.Yaml.Syck
import Control.Monad
type PIR = [Decl]
data Decl
= DeclSub
{ dsName :: !SubName
, dsFlags :: ![SubFlag]
, dsBody :: ![Stmt]
}
| DeclNS
{ dnPackage :: !PkgName
, dnBody :: ![Decl]
}
| DeclInc
{ diFile :: !FilePath
}
| DeclHLL
{ dhLang :: !String
, dhGroup :: !String
}
deriving (Show, Eq, Typeable)
data Stmt
= StmtComment !String
| StmtLine !FilePath !Int
| StmtPad ![(VarName, Expression)] ![Stmt]
| StmtRaw !Doc
| StmtIns !Ins
| StmtSub !SubName ![Stmt]
deriving (Show, Eq, Typeable)
data Ins
= InsLocal !RegType !VarName
| InsNew !LValue !ObjType
| InsBind !LValue !Expression
| InsAssign !LValue !Expression
| InsPrim !(Maybe LValue) !PrimName ![Expression]
| InsFun ![Sig] !Expression ![Expression]
| InsTailFun !Expression ![Expression]
| InsLabel !LabelName
| InsComment !String !(Maybe Ins)
| InsExp !Expression
| InsConst !LValue !ObjType !Expression
deriving (Show, Eq, Typeable)
data Expression
= ExpLV !LValue
| ExpLit !Literal
deriving (Show, Eq, Typeable)
data LValue
= VAR !VarName
| PMC !Int
| STR !Int
| INT !Int
| NUM !Int
| KEYED !LValue !Expression
deriving (Show, Eq, Typeable)
data Literal
= LitStr !String
| LitInt !Integer
| LitNum !Double
deriving (Show, Eq, Typeable)
data SubFlag = SubMAIN | SubLOAD | SubANON | SubMETHOD | SubMULTI ![ObjType] | SubOUTER !SubName
deriving (Show, Eq, Typeable)
data RegType
= RegInt
| RegNum
| RegStr
| RegPMC
deriving (Show, Eq, Typeable)
data ObjType
= PerlScalar | PerlArray | PerlHash
| PerlInt | PerlPair | PerlRef | PerlEnv
| Sub | Closure | Continuation
| BareType String
deriving (Show, Eq, Typeable)
type LabelName = String
type SubName = String
type VarName = String
type PrimName = String
type PkgName = String
type CallConv = String
instance Emit Decl where
emit (DeclNS name decls) = vcat
[ emit ".namespace" <+> brackets (quotes $ emit name)
, emit decls
, emit ".namespace" <+> brackets (quotes $ emit "main")
]
emit (DeclInc name) = emit ".include" <+> (quotes $ emit name)
emit (DeclHLL lang group) = emit ".HLL" <+> commaSep (map (quotes . text) [lang, group])
emit (DeclSub name styps stmts)
= (emit ".sub" <+> doubleQuotes (emit $ quoted name) <+> commaSep styps)
$+$ nested (emitStmts stmts)
$+$ emit ".end"
$+$ emit [DeclSub name' [SubANON, SubOUTER name] body' | StmtSub name' body' <- stmts ]
emitStmts :: [Stmt] -> Doc
emitStmts stmts = vcat (emitLex:emitBody stmts)
where
emitBody [] = []
emitBody [(StmtIns (InsFun _ name args))] = [emit $ StmtIns (InsTailFun name args)]
emitBody (x:xs) = emit x : emitBody xs
emitLex = vcat (map emitVar $ nub (concat [ pad | StmtPad pad _ <- stmts ]))
emitVar :: (VarName, Expression) -> Doc
emitVar (var, exp@(ExpLV (VAR name)))
= emit (InsLocal RegPMC name)
$+$ emit ".lex" <+> commaSep [emit (lit var), emit exp]
emitVar _ = empty
instance Emit SubFlag where
emit (SubOUTER x) = colon <> text "outer" <> parens (doubleQuotes $ emit x)
emit x = (emit . (':':) . map toLower . drop 3 . show) x
curPad :: Int
curPad = 1
instance Emit Stmt where
emit (StmtComment []) = empty
emit (StmtComment str) = vcat [ emit "###" <+> emit line | line <- lines str ]
emit (StmtLine file line) = text "#line" <+> doubleQuotes (emit file) <+> emit line
emit (StmtIns ins) = emit ins
emit (StmtPad pad _) = vcat $
map (\(var, exp) -> emit ("store_lex" .- [lit var, exp])) pad
emit (StmtRaw doc) = doc
emit StmtSub{} = empty
instance Emit RegType where
emit = emit . map toLower . drop 3 . show
instance Emit Ins where
emit (InsLocal rtyp name) = emit ".local" <+> emit rtyp <+> emit name
emit (InsNew ident otyp) = eqSep ident "new" [otyp]
emit (InsAssign ident@(KEYED _ _) lit) = eqSep ident "" [lit]
emit (InsAssign ident lit) = eqSep ident "assign" [lit]
emit (InsBind ident@(KEYED _ _) lit) = eqSep ident "" [lit]
emit (InsBind ident lit) = eqSep ident "set" [lit]
emit (InsPrim (Just ret) name args) = eqSep ret name args
emit (InsPrim Nothing name args) = emit name <+> commaSep args
emit (InsFun rets (ExpLit (LitStr name)) args) = emitFunName "invokecc" name args rets
emit (InsFun rets fun args) = emitFun "invokecc" fun args rets
emit (InsTailFun (ExpLit (LitStr name)) args) = emitFunName "tailcall" name args []
emit (InsTailFun fun args) = emitFun "tailcall" fun args []
emit (InsExp _) = empty
emit (InsConst ident rtyp lit) =
emit ".const" <+> emit rtyp <+> emit ident <+> equals <+> emit lit
emit (InsLabel label) = nest (2) (emit label <> colon)
emit (InsComment comment ins) = emit (StmtComment comment) $+$ emit ins
emitRets :: [Sig] -> Doc
emitRets [] = empty
emitRets rets = emit ("get_results" .- sigList rets)
emitFun :: (Emit b, Emit c) => CallConv -> b -> [c] -> [Sig] -> Doc
emitFun callconv fun args rets = emitArgs args
$+$ emitRets rets
$+$ emit callconv <+> emit fun
emitArgs :: (Emit a) => [a] -> Doc
emitArgs args = emit "set_args" <+> commaSep (sig:map emit args)
where
sig = quotes $ parens (commaSep (replicate (length args) maybeFlatten))
emitFunName :: Emit b => CallConv -> String -> [b] -> [Sig] -> Doc
emitFunName callconv name args rets = eqSep (funPMC :: LValue) "find_name" [LitStr name]
$+$ emitFun callconv (funPMC :: LValue) args rets
noArgs :: [Expression]
noArgs = []
instance Emit ObjType where
emit PerlScalar = emit ".PerlUndef"
emit PerlPair = emit ".Pair"
emit PerlRef = emit ".Ref"
emit (BareType x) = text $ ('.':x)
emit x = emit . ('.':) . show $ x
instance Emit Expression where
emit (ExpLV lhs) = emit lhs
emit (ExpLit lit) = emit lit
instance Emit LValue where
emit (VAR name) = emit name
emit (PMC num) = emit "$P" <> emit num
emit (STR str) = emit "$S" <> emit str
emit (INT str) = emit "$I" <> emit str
emit (NUM str) = emit "$N" <> emit str
emit (KEYED pmc idx) = emit pmc <> brackets (emit idx)
instance Emit Literal where
emit (LitStr str) = text . show $ quoted str
emit (LitInt int) = integer int
emit (LitNum num) = double num
expKeyed :: LValue -> Expression -> Expression
expKeyed = (ExpLV .) . KEYED
quoted :: String -> String
quoted = concatMap quote
where
quote :: Char -> String
quote '\\' = "\\\\"
quote x = [x]
infixl 4 <--
infixl 9 -->
infixl 4 .-
infixl 4 <-&
infixl 4 .&
include :: PkgName -> Decl
hll :: String -> String -> Decl
(<:=) :: LValue -> Expression -> Ins
(<==) :: LValue -> Expression -> Ins
(<--) :: LValue -> PrimName -> [Expression] -> Ins
(.-) :: PrimName -> [Expression] -> Ins
(<-&) :: [Sig] -> Expression -> [Expression] -> Ins
(.&) :: Expression -> [Expression] -> Ins
include = DeclInc
hll = DeclHLL
(<:=) = InsBind
(<==) = InsAssign
(<--) = InsPrim . Just
(.-) = InsPrim Nothing
(<-&) = InsFun
(.&) = InsFun []
lit0 :: Expression
lit0 = lit (0 :: Int)
nullPMC :: (RegClass a) => a
nullPMC = reg $ PMC 0
funPMC :: (RegClass a) => a
funPMC = reg $ PMC 1
rv :: (RegClass a) => a
rv = reg $ PMC 2
arg0 :: (RegClass a) => a
arg0 = reg $ PMC 10
arg1 :: (RegClass a) => a
arg1 = reg $ PMC 11
arg2 :: (RegClass a) => a
arg2 = reg $ PMC 12
arg3 :: (RegClass a) => a
arg3 = reg $ PMC 13
tempPMC :: (RegClass a) => a
tempPMC = reg $ PMC 8
tempPMC2 :: (RegClass a) => a
tempPMC2 = reg $ PMC 9
tempSTR :: (RegClass a) => a
tempSTR = reg $ STR 8
tempSTR2 :: (RegClass a) => a
tempSTR2 = reg $ STR 9
tempSTR3 :: (RegClass a) => a
tempSTR3 = reg $ STR 10
tempINT :: (RegClass a) => a
tempINT = reg $ INT 8
tempINT2 :: (RegClass a) => a
tempINT2 = reg $ INT 9
tempINT3 :: (RegClass a) => a
tempINT3 = reg $ INT 10
tempINT4 :: (RegClass a) => a
tempINT4 = reg $ INT 11
tempNUM :: (RegClass a) => a
tempNUM = reg $ NUM 8
tempNUM2 :: (RegClass a) => a
tempNUM2 = reg $ NUM 9
class RegClass y where
reg :: LValue -> y
instance RegClass LValue where
reg = id
instance RegClass Expression where
reg = ExpLV
instance RegClass Sig where
reg = MkSig [] . ExpLV
class LiteralClass x where
lit :: x -> Expression
instance LiteralClass [[ArgFlag]] where
lit = lit . parens . commaSep . map emit
instance LiteralClass [ArgFlag] where
lit = lit . emit
instance LiteralClass ObjType where
lit = ExpLV . VAR . render . emit
instance LiteralClass Doc where
lit = lit . render
instance LiteralClass String where
lit = ExpLit . LitStr
instance LiteralClass Int where
lit = ExpLit . LitInt . toInteger
instance LiteralClass Bool where
lit False = ExpLit $ LitInt 0
lit True = ExpLit $ LitInt 1
instance LiteralClass Double where
lit = ExpLit . LitNum
sub :: SubName
-> [Sig]
-> [Ins]
-> Decl
sub name [] body = DeclSub name [] (map StmtIns body)
sub name sigs body = DeclSub name [] stmts
where
param = "get_params" .- sigList sigs
stmts = map StmtIns (param:body)
sigList :: [Sig] -> [Expression]
sigList sigs = (flags:map sigIdent sigs)
where
flags = lit . render . parens . commaSep $ map sigFlags sigs
instance Emit [ArgFlag] where
emit = emit . sum . map argVal
data Sig = MkSig
{ sigFlags :: [ArgFlag]
, sigIdent :: Expression
}
deriving (Show, Eq, Typeable)
data ArgFlag
= MkArgFlatten | MkArgSlurpyArray
| MkArgMaybeFlatten | MkArgOptional
deriving (Show, Eq, Typeable)
argVal :: ArgFlag -> Int
argVal MkArgFlatten = 0x20
argVal MkArgSlurpyArray = 0x20
argVal MkArgMaybeFlatten = 0x40
argVal MkArgOptional = 0x80
maybeFlatten :: Doc
maybeFlatten = emit [MkArgMaybeFlatten]
slurpy :: Expression -> Sig
slurpy = MkSig [MkArgSlurpyArray]
(-->) :: Decl -> [Expression] -> Decl
(DeclSub name styps stmts) --> rets = DeclSub name styps $ stmts ++ map StmtIns
[ "set_returns" .- retSigList rets
, "returncc" .- []
]
_ --> _ = error "Can't return from non-sub"
retSigList :: [Expression] -> [Expression]
retSigList rets = (lit sig : rets)
where
sig = parens (commaSep (replicate (length rets) maybeFlatten))
vop1 :: SubName
-> PrimName
-> Decl
vop1 p6name opname =
sub p6name [arg0]
[ InsNew rv PerlScalar
, rv <-- opname $ [arg0]
] --> [rv]
vop2 :: SubName
-> PrimName
-> Decl
vop2 p6name opname =
sub p6name [arg0, arg1]
[ InsNew rv PerlScalar
, rv <-- opname $ [arg0, arg1]
] --> [rv]
vop2keyed :: SubName
-> LValue
-> Decl
vop2keyed p6name temp =
sub p6name [arg0, arg1]
[ temp <:= arg1
, rv <:= expKeyed arg0 (ExpLV temp)
] --> [rv]
vop1x :: SubName
-> PrimName
-> (forall a. RegClass a => a)
-> (forall b. RegClass b => b)
-> Decl
vop1x p6name opname regr reg0 =
sub p6name [arg0]
[ InsNew rv PerlScalar
, reg0 <:= arg0
, regr <-- opname $ [reg0]
, rv <== regr
] --> [rv]
vop1coerce :: SubName
-> (forall a. RegClass a => a)
-> Decl
vop1coerce p6name reg0 =
sub p6name [arg0]
[ InsNew rv PerlScalar
, reg0 <:= arg0
, rv <:= reg0
] --> [rv]
vop2x :: SubName
-> PrimName
-> (forall a. RegClass a => a)
-> (forall b. RegClass b => b)
-> (forall c. RegClass c => c)
-> Decl
vop2x p6name opname regr reg0 reg1 =
sub p6name [arg0, arg1]
[ InsNew rv PerlScalar
, reg0 <:= arg0
, reg1 <:= arg1
, regr <-- opname $ [reg0,reg1]
, rv <== regr
] --> [rv]
vop1ii :: SubName -> PrimName -> Decl
vop1ii p6name opname = vop1x p6name opname tempINT tempINT
vop1nn :: SubName -> PrimName -> Decl
vop1nn p6name opname = vop1x p6name opname tempNUM tempNUM
vop1ss :: SubName -> PrimName -> Decl
vop1ss p6name opname = vop1x p6name opname tempSTR tempSTR
vop1si :: SubName -> PrimName -> Decl
vop1si p6name opname = vop1x p6name opname tempSTR tempINT
vop1is :: SubName -> PrimName -> Decl
vop1is p6name opname = vop1x p6name opname tempINT tempSTR
vop1ip :: SubName -> PrimName -> Decl
vop1ip p6name opname = vop1x p6name opname tempINT tempPMC
vop2iii :: SubName -> PrimName -> Decl
vop2iii p6name opname = vop2x p6name opname tempINT tempINT tempINT2
vop2nnn :: SubName -> PrimName -> Decl
vop2nnn p6name opname = vop2x p6name opname tempNUM tempNUM tempNUM2
vop2iss :: SubName -> PrimName -> Decl
vop2iss p6name opname = vop2x p6name opname tempINT tempSTR tempSTR2
bare :: VarName -> Expression
bare = ExpLV . VAR
collectCC :: [Ins]
collectCC =
[ "set_returns" .- retSigList [tempPMC]
, "returncc" .- []
]
callThunkCC :: Expression -> [Ins]
callThunkCC fun =
[ "set_args" .- sigList []
, "get_results" .- sigList [tempPMC]
, "invokecc" .- [fun]
]
stmtControlLoop :: VarName
-> PrimName
-> Decl
stmtControlLoop name comp = sub ("&statement_control:" ++ name) [arg0, arg1] $
if isPost then ["goto" .- [bare redoL]] else [] ++
[ InsLabel nextL
, [reg tempPMC] <-& arg0 $ []
, comp .- [tempPMC, bare lastL]
, InsLabel redoL
, arg1 .& []
, "goto" .- [bare nextL]
, InsLabel lastL
, "returncc" .- []
]
where
nextL = ("sc_" ++ name ++ "_next")
lastL = ("sc_" ++ name ++ "_last")
redoL = ("sc_" ++ name ++ "_redo")
isPost = "post" `isPrefixOf` name
stmtControlCond :: VarName
-> PrimName
-> Decl
stmtControlCond name comp =
sub ("&statement_control:" ++ name) [arg0, arg1, arg2] body --> [tempPMC]
where
altL = ("sc_" ++ name ++ "_alt")
postL = ("sc_" ++ name ++ "_post")
body = concat
[ [ comp .- [arg0, bare altL] ]
, callThunkCC arg1
, [ "goto" .- [bare postL] ]
, [ InsLabel altL ]
, callThunkCC arg2
, [ InsLabel postL ]
, collectCC
]
op2Logical :: VarName
-> PrimName
-> Decl
op2Logical name comp = sub ("&infix:" ++ name) [arg0, arg1] body --> [tempPMC]
where
altL = ("sc_" ++ escaped name ++ "_alt")
body =
[ comp .- [arg0, bare altL]
, "set_returns" .- retSigList [arg0]
, "returncc" .- []
, InsLabel altL
] ++ callThunkCC arg1 ++ collectCC
escaped :: String -> String
escaped = concatMap esc
where
esc :: Char -> String
esc c | isAlphaNum c = [c]
esc c = ('_':show (ord c))
preludePIR :: Doc
preludePIR = emit $
[ hll "Perl" "perl_group"
, include "iglobals.pasm"
, include "errors.pasm"
, sub "&return" [slurpy arg0]
[ InsNew tempPMC PerlArray
, (tempPMC `KEYED` lit False) <:= arg0
, "throw" .- [tempPMC]
]
, sub "&leave" [slurpy arg0]
[] --> [arg0]
, sub "&statement_control:for" [arg0, arg1]
[ tempPMC <-- "iter" $ [arg0]
, InsLabel "sc_for_next"
, "unless" .- [tempPMC, bare "sc_for_last"]
, tempPMC2 <-- "shift" $ [tempPMC]
, arg1 .& [tempPMC2]
, "goto" .- [bare "sc_for_next"]
, InsLabel "sc_for_last"
, "returncc" .- []
]
, sub "&statement_control:loop" [arg0, arg1, arg2, arg3]
[ InsLabel "sc_loop_next"
, [reg tempPMC] <-& arg1 $ []
, "unless" .- [tempPMC, bare "sc_loop_last"]
, arg2 .& []
, arg3 .& []
, "goto" .- [bare "sc_loop_next"]
, InsLabel "sc_loop_last"
, "returncc" .- []
]
, stmtControlLoop "while" "unless"
, stmtControlLoop "until" "if"
, stmtControlCond "if" "unless"
, stmtControlCond "unless" "if"
, op2Logical "&&" "if"
, op2Logical "||" "unless"
, op2Logical "and" "if"
, op2Logical "or" "unless"
, sub "¬hing" [] []
, sub "&print" [slurpy arg0]
[ tempSTR <-- "join" $ [lit "", arg0]
, "print" .- [tempSTR]
] --> [lit True]
, sub "&say" [slurpy arg0]
[ tempSTR <-- "join" $ [lit "", arg0]
, "print" .- [tempSTR]
, "print" .- [lit "\n"]
] --> [lit True]
, vop1is "&system" "spawnw"
, sub "&infix:," [slurpy arg0]
[] --> [arg0]
, sub "&circumfix:[]" [slurpy arg0]
[ InsNew rv PerlScalar
, InsNew tempPMC PerlArray
, tempPMC <== arg0
, tempPMC2 <-- "new" $ [lit PerlRef, tempPMC]
, rv <== tempPMC2
] --> [rv]
, sub "&prefix:++" [arg0]
[ "inc" .- [arg0]
] --> [arg0]
, sub "&prefix:--" [arg0]
[ "dec" .- [arg0]
] --> [arg0]
, sub "&postfix:++" [arg0]
[ InsNew rv PerlScalar
, rv <== arg0
, "inc" .- [arg0]
] --> [rv]
, sub "&postfix:--" [arg0]
[ InsNew rv PerlScalar
, rv <== arg0
, "dec" .- [arg0]
] --> [rv]
, sub "&prefix:-" [arg0]
[ InsNew rv PerlScalar
, rv <-- "neg" $ [arg0]
] --> [rv]
, vop2 "&infix:+" "add"
, vop2 "&infix:-" "sub"
, vop2 "&infix:*" "mul"
, vop2 "&infix:/" "div"
, vop2 "&infix:%" "mod"
, vop2 "&infix:~" "concat"
, vop1 "&prefix:!" "not"
, vop1 "¬" "not"
, vop2iii "&infix:<" "islt"
, vop2iii "&infix:<=" "isle"
, vop2iii "&infix:>" "isgt"
, vop2iii "&infix:>=" "isge"
, vop2iii "&infix:==" "iseq"
, vop2iii "&infix:!=" "isne"
, vop2iss "&infix:lt" "islt"
, vop2iss "&infix:le" "isle"
, vop2iss "&infix:gt" "isgt"
, vop2iss "&infix:gt" "isge"
, vop2iss "&infix:eq" "iseq"
, vop2iss "&infix:ne" "isne"
, vop1 "&prefix:?^" "bnot"
, vop2keyed "&postcircumfix:{}" tempSTR
, vop2keyed "&postcircumfix:[]" tempINT
, vop1coerce "&prefix:+" tempNUM
, vop1coerce "&prefix:~" tempSTR
, vop1coerce "&int" tempINT
, sub "&true" [arg0]
[ InsNew rv PerlScalar
, rv <:= (ExpLit . LitInt) 1
, "if" .- [arg0, bare "true_pmc_is_true"]
, rv <:= (ExpLit . LitInt) 0
, InsLabel "true_pmc_is_true"
] --> [rv]
, vop1is "&chars" "length"
, vop1is "&bytes" "bytelength"
, sub "&prefix:\\" [arg0]
[ tempPMC <-- "new" $ [lit PerlRef, arg0]
] --> [rv]
, sub "&infix:=>" [arg0, arg1]
[ InsNew rv PerlPair
, rv `KEYED` arg0 <:= arg1
] --> [rv]
, sub "&infix:.." [arg0, arg1]
[ tempINT <:= arg0
, InsNew rv PerlArray
, InsLabel "range_next"
, "lt_num" .- [arg1, tempINT, bare "range_end"]
, "push" .- [rv, tempINT]
, "inc" .- [tempINT]
, "goto" .- [bare "range_next"]
, InsLabel "range_end"
] --> [rv]
, sub "&substr" [arg0, arg1, arg2]
[ tempSTR <:= arg0
, tempINT <:= arg1
, tempINT2 <:= arg2
, tempSTR2 <-- "substr" $ [tempSTR, tempINT, tempINT2]
, InsNew rv PerlScalar
, rv <:= tempSTR2
] --> [rv]
, vop1si "&chr" "chr"
, vop1is "&ord" "ord"
, vop2x "&infix:x" "repeat" tempSTR tempSTR tempINT
, vop1ss "&lc" "downcase"
, vop1ss "&uc" "upcase"
, sub "&undef" []
[ InsNew rv PerlScalar
] --> [rv]
, sub "&undefine" [arg0]
[ InsNew tempPMC PerlScalar
, arg0 <== tempPMC
] --> [arg0]
, vop1ip "&defined" "defined"
, vop1 "&clone" "clone"
, sub "&pop" [arg0]
[ rv <-- "pop" $ [arg0]
] --> [rv]
, sub "&push" [arg0, arg1]
[ "push" .- [arg0, arg1]
] --> [lit True]
, sub "&delete" [arg0, arg1]
[ rv <:= expKeyed arg0 arg1
, "delete" .- [expKeyed arg0 arg1]
] --> [rv]
, sub "&exists" [arg0, arg1]
[ tempINT <-- "exists" $ [expKeyed arg0 arg1]
, InsNew rv PerlScalar
, rv <:= tempINT
] --> [rv]
, sub "&join" [arg0, arg1]
[ InsNew rv PerlScalar
, tempSTR <:= arg0
, tempSTR2 <-- "join" $ [tempSTR, arg1]
, rv <== tempSTR2
] --> [rv]
, DeclNS "Perl6::Internals"
[ sub "&symbolic_deref" [arg0, slurpy arg1]
[ tempSTR <-- "join" $ [lit "::", arg1]
, tempSTR2 <:= arg0
, tempSTR <-- "concat" $ [tempSTR2, tempSTR]
, rv <-- "find_name" $ [tempSTR]
] --> [rv]
, sub "&exit" [arg0]
[ tempPMC <-- "find_global" $ [lit "main", lit "&*END"]
, "set_args" .- sigList []
, "invokecc" .- [tempPMC]
, tempINT <:= arg0
, "exit" .- [tempINT]
]
, sub "&sleep" [arg0]
[ tempNUM <:= arg0
, "sleep" .- [tempNUM]
]
, sub "&compile_pir" [arg0]
[ tempSTR <:= arg0
, tempPMC <-- "compreg" $ [lit "PIR"]
, tempPMC2 <-- "compile" $ [tempPMC, tempSTR]
] --> [tempPMC2]
, sub "&eval_pir" [arg0]
[ tempPMC <-- "open" $ [lit "temp.pl", lit ">"]
, "print" .- [tempPMC, arg0]
, "close" .- [tempPMC]
, tempPMC <-- "open" $ [lit "pugs -CPIR temp.pl", lit "-|"]
, InsNew rv PerlScalar
, rv <:= lit ""
, InsLabel "eval_pir_read_pre_next"
, tempSTR <-- "readline" $ [tempPMC]
, "ne" .- [tempSTR, lit ".sub \"init\" :main :anon\n", bare "eval_pir_read_pre_next"]
, InsLabel "eval_pir_read_next"
, tempSTR <-- "readline" $ [tempPMC]
, "eq" .- [tempSTR, lit ".end\n", bare "eval_pir_done"]
, rv <-- "concat" $ [tempSTR]
, "if" .- [tempPMC, bare "eval_pir_read_next"]
, InsLabel "eval_pir_done"
, "close" .- [tempPMC]
] --> [rv]
]
, sub "&abs" [arg0]
[ InsNew rv PerlScalar
, rv <== arg0
, "abs" .- [arg0]
] --> [rv]
, vop1nn "&exp" "exp"
, vop1nn "&ln" "ln"
, vop1nn "&log2" "log2"
, vop1nn "&log10" "log10"
, vop1nn "&sqrt" "sqrt"
, vop1 "&sin" "sin"
, vop1 "&cos" "cos"
, vop1 "&tan" "tan"
, vop1 "&sec" "sec"
, vop1 "&asin" "asin"
, vop1 "&acos" "acos"
, vop1 "&atan" "atan"
, vop1 "&asec" "asec"
, vop1 "&sinh" "sinh"
, vop1 "&cosh" "cosh"
, vop1 "&tanh" "tanh"
, vop1 "&sech" "sech"
, vop1nn "&ceil" "ceil"
, vop1nn "&floor" "floor"
, vop1ii "&fact" "fact"
, vop2iii "&gcd" "gcd"
, vop2iii "&lcm" "lcm"
, vop2nnn "&pow" "pow"
, sub "&time" []
[ InsNew rv PerlScalar
, tempNUM <-- "time" $ []
, rv <:= tempNUM
, "sub" .- [rv, ExpLit . LitNum $ 946684800]
] --> [rv]
, sub "&split" [arg0, arg1]
[ InsNew rv PerlScalar
, tempSTR <:= arg0
, tempSTR2 <:= arg1
, "ne" .- [tempSTR, lit "\n", bare "split_normally"]
, InsNew rv PerlArray
, tempINT <:= (ExpLit . LitInt $ 0)
, tempINT4 <-- "length" $ [tempSTR]
, InsLabel "split_loop"
, tempINT2 <-- "index" $ [tempSTR2, tempSTR, tempINT]
, "lt" .- [tempINT2, ExpLit . LitInt $ 0, bare "split_last"]
, tempINT3 <-- "sub" $ [tempINT2, tempINT]
, tempSTR3 <-- "substr" $ [tempSTR2, tempINT, tempINT3]
, tempINT <-- "add" $ [tempINT2, tempINT4]
, "push" .- [rv, tempSTR3]
, "goto" .- [bare "split_loop"]
, InsLabel "split_last"
, tempSTR3 <-- "substr" $ [tempSTR2, tempINT]
, "push" .- [rv, tempSTR3]
, "goto" .- [bare "split_done"]
, InsLabel "split_normally"
, tempPMC <-- "split" $ [tempSTR, tempSTR2]
, rv <== tempPMC
, InsLabel "split_done"
] --> [rv]
, sub "&True" []
[] --> [lit True]
, sub "&False" []
[] --> [lit False]
, sub "&Bool::True" []
[] --> [lit True]
, sub "&Bool::False" []
[] --> [lit False]
]
instance YAML Doc where
asYAML = asYAML . render
instance Typeable Doc where
typeOf _ = typeOf ()
instance YAML Decl where
fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
"DeclSub" -> do
let EMap assocs = e
let [aa, ab, ac] = map snd assocs
liftM3 DeclSub (fromYAML aa) (fromYAML ab) (fromYAML ac)
"DeclNS" -> do
let EMap assocs = e
let [aa, ab] = map snd assocs
liftM2 DeclNS (fromYAML aa) (fromYAML ab)
"DeclInc" -> do
let EMap assocs = e
let [aa] = map snd assocs
liftM DeclInc (fromYAML aa)
"DeclHLL" -> do
let EMap assocs = e
let [aa, ab] = map snd assocs
liftM2 DeclHLL (fromYAML aa) (fromYAML ab)
_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["DeclSub","DeclNS","DeclInc","DeclHLL"] ++ " in node " ++ show e
fromYAML e = fail $ "no tag found: expecting " ++ show ["DeclSub","DeclNS","DeclInc","DeclHLL"] ++ " in node " ++ show e
asYAML (DeclSub aa ab ac) = asYAMLmap "DeclSub"
[("dsName", asYAML aa), ("dsFlags", asYAML ab),
("dsBody", asYAML ac)]
asYAML (DeclNS aa ab) = asYAMLmap "DeclNS"
[("dnPackage", asYAML aa), ("dnBody", asYAML ab)]
asYAML (DeclInc aa) = asYAMLmap "DeclInc" [("diFile", asYAML aa)]
asYAML (DeclHLL aa ab) = asYAMLmap "DeclHLL"
[("dhLang", asYAML aa), ("dhGroup", asYAML ab)]
instance YAML Stmt where
fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
"StmtComment" -> do
let ESeq [aa] = e
liftM StmtComment (fromYAML aa)
"StmtLine" -> do
let ESeq [aa, ab] = e
liftM2 StmtLine (fromYAML aa) (fromYAML ab)
"StmtPad" -> do
let ESeq [aa, ab] = e
liftM2 StmtPad (fromYAML aa) (fromYAML ab)
"StmtRaw" -> do
let ESeq [aa] = e
liftM StmtRaw (fromYAML aa)
"StmtIns" -> do
let ESeq [aa] = e
liftM StmtIns (fromYAML aa)
"StmtSub" -> do
let ESeq [aa, ab] = e
liftM2 StmtSub (fromYAML aa) (fromYAML ab)
_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["StmtComment","StmtLine","StmtPad","StmtRaw","StmtIns","StmtSub"] ++ " in node " ++ show e
fromYAML e = fail $ "no tag found: expecting " ++ show ["StmtComment","StmtLine","StmtPad","StmtRaw","StmtIns","StmtSub"] ++ " in node " ++ show e
asYAML (StmtComment aa) = asYAMLseq "StmtComment" [asYAML aa]
asYAML (StmtLine aa ab) = asYAMLseq "StmtLine"
[asYAML aa, asYAML ab]
asYAML (StmtPad aa ab) = asYAMLseq "StmtPad" [asYAML aa, asYAML ab]
asYAML (StmtRaw aa) = asYAMLseq "StmtRaw" [asYAML aa]
asYAML (StmtIns aa) = asYAMLseq "StmtIns" [asYAML aa]
asYAML (StmtSub aa ab) = asYAMLseq "StmtSub" [asYAML aa, asYAML ab]
instance YAML Ins where
fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
"InsLocal" -> do
let ESeq [aa, ab] = e
liftM2 InsLocal (fromYAML aa) (fromYAML ab)
"InsNew" -> do
let ESeq [aa, ab] = e
liftM2 InsNew (fromYAML aa) (fromYAML ab)
"InsBind" -> do
let ESeq [aa, ab] = e
liftM2 InsBind (fromYAML aa) (fromYAML ab)
"InsAssign" -> do
let ESeq [aa, ab] = e
liftM2 InsAssign (fromYAML aa) (fromYAML ab)
"InsPrim" -> do
let ESeq [aa, ab, ac] = e
liftM3 InsPrim (fromYAML aa) (fromYAML ab) (fromYAML ac)
"InsFun" -> do
let ESeq [aa, ab, ac] = e
liftM3 InsFun (fromYAML aa) (fromYAML ab) (fromYAML ac)
"InsTailFun" -> do
let ESeq [aa, ab] = e
liftM2 InsTailFun (fromYAML aa) (fromYAML ab)
"InsLabel" -> do
let ESeq [aa] = e
liftM InsLabel (fromYAML aa)
"InsComment" -> do
let ESeq [aa, ab] = e
liftM2 InsComment (fromYAML aa) (fromYAML ab)
"InsExp" -> do
let ESeq [aa] = e
liftM InsExp (fromYAML aa)
"InsConst" -> do
let ESeq [aa, ab, ac] = e
liftM3 InsConst (fromYAML aa) (fromYAML ab) (fromYAML ac)
_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["InsLocal","InsNew","InsBind","InsAssign","InsPrim","InsFun","InsTailFun","InsLabel","InsComment","InsExp","InsConst"] ++ " in node " ++ show e
fromYAML e = fail $ "no tag found: expecting " ++ show ["InsLocal","InsNew","InsBind","InsAssign","InsPrim","InsFun","InsTailFun","InsLabel","InsComment","InsExp","InsConst"] ++ " in node " ++ show e
asYAML (InsLocal aa ab) = asYAMLseq "InsLocal"
[asYAML aa, asYAML ab]
asYAML (InsNew aa ab) = asYAMLseq "InsNew" [asYAML aa, asYAML ab]
asYAML (InsBind aa ab) = asYAMLseq "InsBind" [asYAML aa, asYAML ab]
asYAML (InsAssign aa ab) = asYAMLseq "InsAssign"
[asYAML aa, asYAML ab]
asYAML (InsPrim aa ab ac) = asYAMLseq "InsPrim"
[asYAML aa, asYAML ab, asYAML ac]
asYAML (InsFun aa ab ac) = asYAMLseq "InsFun"
[asYAML aa, asYAML ab, asYAML ac]
asYAML (InsTailFun aa ab) = asYAMLseq "InsTailFun"
[asYAML aa, asYAML ab]
asYAML (InsLabel aa) = asYAMLseq "InsLabel" [asYAML aa]
asYAML (InsComment aa ab) = asYAMLseq "InsComment"
[asYAML aa, asYAML ab]
asYAML (InsExp aa) = asYAMLseq "InsExp" [asYAML aa]
asYAML (InsConst aa ab ac) = asYAMLseq "InsConst"
[asYAML aa, asYAML ab, asYAML ac]
instance YAML Expression where
fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
"ExpLV" -> do
let ESeq [aa] = e
liftM ExpLV (fromYAML aa)
"ExpLit" -> do
let ESeq [aa] = e
liftM ExpLit (fromYAML aa)
_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["ExpLV","ExpLit"] ++ " in node " ++ show e
fromYAML e = fail $ "no tag found: expecting " ++ show ["ExpLV","ExpLit"] ++ " in node " ++ show e
asYAML (ExpLV aa) = asYAMLseq "ExpLV" [asYAML aa]
asYAML (ExpLit aa) = asYAMLseq "ExpLit" [asYAML aa]
instance YAML LValue where
fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
"VAR" -> do
let ESeq [aa] = e
liftM VAR (fromYAML aa)
"PMC" -> do
let ESeq [aa] = e
liftM PMC (fromYAML aa)
"STR" -> do
let ESeq [aa] = e
liftM STR (fromYAML aa)
"INT" -> do
let ESeq [aa] = e
liftM INT (fromYAML aa)
"NUM" -> do
let ESeq [aa] = e
liftM NUM (fromYAML aa)
"KEYED" -> do
let ESeq [aa, ab] = e
liftM2 KEYED (fromYAML aa) (fromYAML ab)
_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["VAR","PMC","STR","INT","NUM","KEYED"] ++ " in node " ++ show e
fromYAML e = fail $ "no tag found: expecting " ++ show ["VAR","PMC","STR","INT","NUM","KEYED"] ++ " in node " ++ show e
asYAML (VAR aa) = asYAMLseq "VAR" [asYAML aa]
asYAML (PMC aa) = asYAMLseq "PMC" [asYAML aa]
asYAML (STR aa) = asYAMLseq "STR" [asYAML aa]
asYAML (INT aa) = asYAMLseq "INT" [asYAML aa]
asYAML (NUM aa) = asYAMLseq "NUM" [asYAML aa]
asYAML (KEYED aa ab) = asYAMLseq "KEYED" [asYAML aa, asYAML ab]
instance YAML Literal where
fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
"LitStr" -> do
let ESeq [aa] = e
liftM LitStr (fromYAML aa)
"LitInt" -> do
let ESeq [aa] = e
liftM LitInt (fromYAML aa)
"LitNum" -> do
let ESeq [aa] = e
liftM LitNum (fromYAML aa)
_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["LitStr","LitInt","LitNum"] ++ " in node " ++ show e
fromYAML e = fail $ "no tag found: expecting " ++ show ["LitStr","LitInt","LitNum"] ++ " in node " ++ show e
asYAML (LitStr aa) = asYAMLseq "LitStr" [asYAML aa]
asYAML (LitInt aa) = asYAMLseq "LitInt" [asYAML aa]
asYAML (LitNum aa) = asYAMLseq "LitNum" [asYAML aa]
instance YAML SubFlag where
fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
"SubMAIN" -> do
return SubMAIN
"SubLOAD" -> do
return SubLOAD
"SubANON" -> do
return SubANON
"SubMETHOD" -> do
return SubMETHOD
"SubMULTI" -> do
let ESeq [aa] = e
liftM SubMULTI (fromYAML aa)
"SubOUTER" -> do
let ESeq [aa] = e
liftM SubOUTER (fromYAML aa)
_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["SubMAIN","SubLOAD","SubANON","SubMETHOD","SubMULTI","SubOUTER"] ++ " in node " ++ show e
fromYAML e = fail $ "no tag found: expecting " ++ show ["SubMAIN","SubLOAD","SubANON","SubMETHOD","SubMULTI","SubOUTER"] ++ " in node " ++ show e
asYAML (SubMAIN) = asYAMLcls "SubMAIN"
asYAML (SubLOAD) = asYAMLcls "SubLOAD"
asYAML (SubANON) = asYAMLcls "SubANON"
asYAML (SubMETHOD) = asYAMLcls "SubMETHOD"
asYAML (SubMULTI aa) = asYAMLseq "SubMULTI" [asYAML aa]
asYAML (SubOUTER aa) = asYAMLseq "SubOUTER" [asYAML aa]
instance YAML RegType where
fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
"RegInt" -> do
return RegInt
"RegNum" -> do
return RegNum
"RegStr" -> do
return RegStr
"RegPMC" -> do
return RegPMC
_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["RegInt","RegNum","RegStr","RegPMC"] ++ " in node " ++ show e
fromYAML e = fail $ "no tag found: expecting " ++ show ["RegInt","RegNum","RegStr","RegPMC"] ++ " in node " ++ show e
asYAML (RegInt) = asYAMLcls "RegInt"
asYAML (RegNum) = asYAMLcls "RegNum"
asYAML (RegStr) = asYAMLcls "RegStr"
asYAML (RegPMC) = asYAMLcls "RegPMC"
instance YAML ObjType where
fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
"PerlScalar" -> do
return PerlScalar
"PerlArray" -> do
return PerlArray
"PerlHash" -> do
return PerlHash
"PerlInt" -> do
return PerlInt
"PerlPair" -> do
return PerlPair
"PerlRef" -> do
return PerlRef
"PerlEnv" -> do
return PerlEnv
"Sub" -> do
return Sub
"Closure" -> do
return Closure
"Continuation" -> do
return Continuation
"BareType" -> do
let ESeq [aa] = e
liftM BareType (fromYAML aa)
_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["PerlScalar","PerlArray","PerlHash","PerlInt","PerlPair","PerlRef","PerlEnv","Sub","Closure","Continuation","BareType"] ++ " in node " ++ show e
fromYAML e = fail $ "no tag found: expecting " ++ show ["PerlScalar","PerlArray","PerlHash","PerlInt","PerlPair","PerlRef","PerlEnv","Sub","Closure","Continuation","BareType"] ++ " in node " ++ show e
asYAML (PerlScalar) = asYAMLcls "PerlScalar"
asYAML (PerlArray) = asYAMLcls "PerlArray"
asYAML (PerlHash) = asYAMLcls "PerlHash"
asYAML (PerlInt) = asYAMLcls "PerlInt"
asYAML (PerlPair) = asYAMLcls "PerlPair"
asYAML (PerlRef) = asYAMLcls "PerlRef"
asYAML (PerlEnv) = asYAMLcls "PerlEnv"
asYAML (Sub) = asYAMLcls "Sub"
asYAML (Closure) = asYAMLcls "Closure"
asYAML (Continuation) = asYAMLcls "Continuation"
asYAML (BareType aa) = asYAMLseq "BareType" [asYAML aa]
instance YAML Sig where
fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
"MkSig" -> do
let EMap assocs = e
let [aa, ab] = map snd assocs
liftM2 MkSig (fromYAML aa) (fromYAML ab)
_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkSig"] ++ " in node " ++ show e
fromYAML e = fail $ "no tag found: expecting " ++ show ["MkSig"] ++ " in node " ++ show e
asYAML (MkSig aa ab) = asYAMLmap "MkSig"
[("sigFlags", asYAML aa), ("sigIdent", asYAML ab)]
instance YAML ArgFlag where
fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
"MkArgFlatten" -> do
return MkArgFlatten
"MkArgSlurpyArray" -> do
return MkArgSlurpyArray
"MkArgMaybeFlatten" -> do
return MkArgMaybeFlatten
"MkArgOptional" -> do
return MkArgOptional
_ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkArgFlatten","MkArgSlurpyArray","MkArgMaybeFlatten","MkArgOptional"] ++ " in node " ++ show e
fromYAML e = fail $ "no tag found: expecting " ++ show ["MkArgFlatten","MkArgSlurpyArray","MkArgMaybeFlatten","MkArgOptional"] ++ " in node " ++ show e
asYAML (MkArgFlatten) = asYAMLcls "MkArgFlatten"
asYAML (MkArgSlurpyArray) = asYAMLcls "MkArgSlurpyArray"
asYAML (MkArgMaybeFlatten) = asYAMLcls "MkArgMaybeFlatten"
asYAML (MkArgOptional) = asYAMLcls "MkArgOptional"