{-| Parrot PIR syntax tree. > All that is gold does not glitter, > Not all those who wander are lost; > The old that is strong does not wither, > Deep roots are not reached by the frost. -} 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 {-! global : YAML !-} {-| PIR code consists of declarations. -} type PIR = [Decl] data Decl = DeclSub { dsName :: !SubName , dsFlags :: ![SubFlag] , dsBody :: ![Stmt] } -- ^ Subroutine declaration | DeclNS { dnPackage :: !PkgName , dnBody :: ![Decl] } -- ^ Namespace declaration | DeclInc { diFile :: !FilePath } -- ^ @.include@ directive | DeclHLL { dhLang :: !String , dhGroup :: !String } -- ^ @HLL@ directive deriving (Show, Eq, Typeable) data Stmt = StmtComment !String -- ^ Comment | StmtLine !FilePath !Int -- ^ @#line@ directive | StmtPad ![(VarName, Expression)] ![Stmt] -- ^ Lexical Pad | StmtRaw !Doc -- ^ Backdoor into raw @Doc@ | StmtIns !Ins -- ^ Generic instructions | StmtSub !SubName ![Stmt] -- ^ Inner subroutine deriving (Show, Eq, Typeable) data Ins = InsLocal !RegType !VarName -- ^ @.local@ directive | InsNew !LValue !ObjType -- ^ @new@ opcode | InsBind !LValue !Expression -- ^ @set@ opcode | InsAssign !LValue !Expression -- ^ @assign@ opcode | InsPrim !(Maybe LValue) !PrimName ![Expression] -- ^ Other opcodes | InsFun ![Sig] !Expression ![Expression]-- ^ Function call | InsTailFun !Expression ![Expression] -- ^ Tail call | InsLabel !LabelName -- ^ Label | InsComment !String !(Maybe Ins) -- ^ Comment | InsExp !Expression -- ^ Generic expressions | InsConst !LValue !ObjType !Expression -- ^ Constant deriving (Show, Eq, Typeable) data Expression = ExpLV !LValue -- ^ Variables | ExpLit !Literal -- ^ Literals deriving (Show, Eq, Typeable) data LValue = VAR !VarName -- ^ A variable declared by @.local@ | PMC !Int -- ^ PMC register /n/ | STR !Int -- ^ String register /n/ | INT !Int -- ^ Integer register /n/ | NUM !Int -- ^ Number register /n/ | KEYED !LValue !Expression deriving (Show, Eq, Typeable) data Literal = LitStr !String -- ^ A literal string | LitInt !Integer -- ^ A literal integer | LitNum !Double -- ^ A literal number deriving (Show, Eq, Typeable) {-| Tags a PIR subroutine definition with @\@MAIN@, @\@LOAD@, @\@ANON@, @\@METHOD@, or @\@MULTI@. -} data SubFlag = SubMAIN | SubLOAD | SubANON | SubMETHOD | SubMULTI ![ObjType] | SubOUTER !SubName deriving (Show, Eq, Typeable) data RegType = RegInt -- ^ @I@ (Integer) register | RegNum -- ^ @N@ (Number) register | RegStr -- ^ @S@ (String) register | RegPMC -- ^ @P@ (PMC) register deriving (Show, Eq, Typeable) {-| A PMC type, which, for example, can be given as an argument to the @new@ opcode (e.g. @new .PerlScalar@). -} 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 {-| Emits PIR code for declarations (namespace, include, or sub declarations). -} 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]) -- Perform λ-lifting here 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 {-| Emits PIR code for a 'SubFlag' (e.g. @:main@, @:anon@, etc.). -} 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 "new_pad" <+> int curPad ] ++ -} 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] -- XXX questionable emit (InsAssign ident lit) = eqSep ident "assign" [lit] emit (InsBind ident@(KEYED _ _) lit) = eqSep ident "" [lit] -- XXX questionable emit (InsBind ident lit) = eqSep ident "set" [lit] emit (InsPrim (Just ret) name args) = eqSep ret name args -- emit (InsPrim Nothing "store_lex" (_:args)) = -- -- XXX - horrible hack! perl 4! -- emit (InsPrim Nothing "store_global" 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 = [] {-| Emits PIR code for an 'ObjType' (e.g. @.PerlScalar@). -} instance Emit ObjType where emit PerlScalar = emit ".PerlUndef" -- XXX special case emit PerlPair = emit ".Pair" -- XXX special case emit PerlRef = emit ".Ref" -- XXX special case 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) {-| Emits a literal (a 'LitStr', 'LitInt', or 'LitNum'), and escapes if necessary. -} 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@ directive. -} include :: PkgName -> Decl {-| @.HLL@ directive. -} hll :: String -> String -> Decl {-| Short for 'InsBind' (binding). -} (<:=) :: LValue -> Expression -> Ins {-| Short for 'InsAssign'. -} (<==) :: LValue -> Expression -> Ins {-| Calls an opcode which returns a value. -} (<--) :: LValue -> PrimName -> [Expression] -> Ins {-| Calls an opcode, ignoring any return values. -} (.-) :: PrimName -> [Expression] -> Ins {-| Calls an user-defined sub which returns a list of values. -} (<-&) :: [Sig] -> Expression -> [Expression] -> Ins {-| Calls an user-defined sub, ignoring any return values. -} (.&) :: Expression -> [Expression] -> Ins include = DeclInc hll = DeclHLL (<:=) = InsBind (<==) = InsAssign (<--) = InsPrim . Just (.-) = InsPrim Nothing (<-&) = InsFun (.&) = InsFun [] {-| Literal zero -} lit0 :: Expression lit0 = lit (0 :: Int) {-| @$P0@ register -} nullPMC :: (RegClass a) => a nullPMC = reg $ PMC 0 {-| @$P1@ register -} funPMC :: (RegClass a) => a funPMC = reg $ PMC 1 {-| @$P2@ register -} rv :: (RegClass a) => a rv = reg $ PMC 2 {-| @$P10@ register -} arg0 :: (RegClass a) => a arg0 = reg $ PMC 10 {-| @$P11@ register -} arg1 :: (RegClass a) => a arg1 = reg $ PMC 11 {-| @$P12@ register -} arg2 :: (RegClass a) => a arg2 = reg $ PMC 12 {-| @$P13@ register -} arg3 :: (RegClass a) => a arg3 = reg $ PMC 13 {-| @$P8@ register -} tempPMC :: (RegClass a) => a tempPMC = reg $ PMC 8 {-| @$P9@ register -} tempPMC2 :: (RegClass a) => a tempPMC2 = reg $ PMC 9 {-| @$S8@ register -} tempSTR :: (RegClass a) => a tempSTR = reg $ STR 8 {-| @$S9@ register -} tempSTR2 :: (RegClass a) => a tempSTR2 = reg $ STR 9 {-| @$S10@ register -} tempSTR3 :: (RegClass a) => a tempSTR3 = reg $ STR 10 {-| @$I8@ register -} tempINT :: (RegClass a) => a tempINT = reg $ INT 8 {-| @$I9@ register -} tempINT2 :: (RegClass a) => a tempINT2 = reg $ INT 9 {-| @$I10@ register -} tempINT3 :: (RegClass a) => a tempINT3 = reg $ INT 10 {-| @$I11@ register -} tempINT4 :: (RegClass a) => a tempINT4 = reg $ INT 11 {-| @$N8@ register -} tempNUM :: (RegClass a) => a tempNUM = reg $ NUM 8 {-| @$N9@ register -} 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 -- type LitOf x 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 {-| Subroutine declaration. -} sub :: SubName -- ^ Name of the subroutine -> [Sig] -- ^ Signature -> [Ins] -- ^ Subroutine body -> Decl -- ^ The final subroutine declaration 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] {-| Marks a parameter as slurpy. -} slurpy :: Expression -> Sig slurpy = MkSig [MkArgSlurpyArray] {-| Returns from a sub. -} (-->) :: 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)) {-| In the case a Perl 6 builtin corresponds exactly to a PIR opcode, you can use 'vop1' to create an appropriate wrapper for an opcode expecting /one/ argument. -} vop1 :: SubName -- ^ Perl 6 name of the opcode to wrap -> PrimName -- ^ PIR opcode -> Decl -- ^ Final subroutine declaration vop1 p6name opname = sub p6name [arg0] [ InsNew rv PerlScalar , rv <-- opname $ [arg0] ] --> [rv] {-| In the case a Perl 6 builtin corresponds exactly to a PIR opcode, you can use 'vop2' to create an appropriate wrapper for an opcode expecting /two/ arguments. -} vop2 :: SubName -- ^ Perl 6 name of the opcode to wrap -> PrimName -- ^ PIR opcode -> Decl -- ^ Final subroutine declaration vop2 p6name opname = sub p6name [arg0, arg1] [ InsNew rv PerlScalar , rv <-- opname $ [arg0, arg1] ] --> [rv] {-| Creates a sub which accepts a thing which allows keyed access (for example aggregates) and an index. -} vop2keyed :: SubName -- ^ Perl 6 name of the sub to create -> LValue -- ^ Intermediate register to convert the index to -- (e.g. 'tempINT' or 'tempSTR') -> Decl -- ^ Final subroutine declaration vop2keyed p6name temp = sub p6name [arg0, arg1] [ temp <:= arg1 , rv <:= expKeyed arg0 (ExpLV temp) ] --> [rv] {-| Generic wrapper for unary opcodes. -} --vop1x :: (RegClass a, RegClass b) => SubName -> PrimName -> a -> b -> Decl vop1x :: SubName -- ^ Perl 6 name of the sub to create -> PrimName -- ^ Opcode to wrap -> (forall a. RegClass a => a) -- ^ Register to use for the return value -- of the op -> (forall b. RegClass b => b) -- ^ Register type to convert the -- parameter to -> Decl -- ^ Final subroutine declaration vop1x p6name opname regr reg0 = sub p6name [arg0] [ InsNew rv PerlScalar , reg0 <:= arg0 , regr <-- opname $ [reg0] , rv <== regr ] --> [rv] {-| Generic wrapper for coercion\/context forcing (used by @&prefix:\<\+\>@, @&prefix:\<\~\>@, etc.) -} vop1coerce :: SubName -- ^ Perl 6 name of the sub to create -> (forall a. RegClass a => a) -- ^ Register type to convert the -- parameter to -> Decl -- ^ Final subroutine declaration vop1coerce p6name reg0 = sub p6name [arg0] [ InsNew rv PerlScalar , reg0 <:= arg0 , rv <:= reg0 ] --> [rv] {-| Generic wrapper for two-ary opcodes. -} vop2x :: SubName -- ^ Perl 6 name of the sub to create -> PrimName -- ^ Opcode to wrap -> (forall a. RegClass a => a) -- ^ Register to use for the return value -- of the op -> (forall b. RegClass b => b) -- ^ Register type to convert the -- first parameter to -> (forall c. RegClass c => c) -- ^ Register type to convert the -- second parameter to -> Decl -- ^ Final subroutine declaration vop2x p6name opname regr reg0 reg1 = sub p6name [arg0, arg1] [ InsNew rv PerlScalar , reg0 <:= arg0 , reg1 <:= arg1 , regr <-- opname $ [reg0,reg1] , rv <== regr ] --> [rv] {-| Wrapper for an opcode which accepts and returns an @I@ register. -} vop1ii :: SubName -> PrimName -> Decl vop1ii p6name opname = vop1x p6name opname tempINT tempINT {-| Wrapper for an opcode which accepts and returns a @N@ register. -} vop1nn :: SubName -> PrimName -> Decl vop1nn p6name opname = vop1x p6name opname tempNUM tempNUM {-| Wrapper for an opcode which accepts and returns a @S@ register. -} vop1ss :: SubName -> PrimName -> Decl vop1ss p6name opname = vop1x p6name opname tempSTR tempSTR {-| Wrapper for an opcode which returns a @S@ register and accepts a @I@ register. -} vop1si :: SubName -> PrimName -> Decl vop1si p6name opname = vop1x p6name opname tempSTR tempINT {-| Wrapper for an opcode which returns a @I@ register and accepts a @S@ register. -} vop1is :: SubName -> PrimName -> Decl vop1is p6name opname = vop1x p6name opname tempINT tempSTR {-| Wrapper for an opcode which returns a @I@ register and accepts a @P@ register. -} vop1ip :: SubName -> PrimName -> Decl vop1ip p6name opname = vop1x p6name opname tempINT tempPMC {-| Wrapper for an opcode which accepts and returns @I@ registers. -} vop2iii :: SubName -> PrimName -> Decl vop2iii p6name opname = vop2x p6name opname tempINT tempINT tempINT2 {-| Wrapper for an opcode which accepts and returns @N@ registers. -} vop2nnn :: SubName -> PrimName -> Decl vop2nnn p6name opname = vop2x p6name opname tempNUM tempNUM tempNUM2 {-| Wrapper for an opcode which accepts two @S@ registers and returns a native integer (@I@ register). -} 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] ] {-| Creates appropriate @&statement_control:foo@ subroutines. -} stmtControlLoop :: VarName -- ^ Perl 6 name of the new sub -> PrimName -- ^ PIR opcode to use for branching -> Decl -- ^ Final declaration of the sub 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 {-| Creates appropriate @&statement_control:foo@ subroutines. -} stmtControlCond :: VarName -- ^ Perl 6 name of the new sub -> PrimName -- ^ PIR opcode to use for branching -> Decl -- ^ Final declaration of the sub 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 ] {-| Creates appropriate @&infix:foo@ subs for logical operators (@||@, @&&@, etc.). -} op2Logical :: VarName -- ^ Perl 6 name of the sub to create -> PrimName -- ^ PIR opcode to use (@if@, @unless@) -> Decl -- ^ Final declaration of the sub 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 {-| Escapes characters which have a special meaning in PIR. -} escaped :: String -> String escaped = concatMap esc where esc :: Char -> String esc c | isAlphaNum c = [c] esc c = ('_':show (ord c)) {-| The Prelude, defining primitives like @&say@, @&infix:+@, etc. -} preludePIR :: Doc preludePIR = emit $ [ hll "Perl" "perl_group" , include "iglobals.pasm" , include "errors.pasm" -- Control flowy , 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 .& [] -- throw away the result of body... , arg3 .& [] -- ...and the post-condition , "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" [] [] -- IO , 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" -- Operators , 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] -- Strings , 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" -- Objects , sub "&undef" [] [ InsNew rv PerlScalar ] --> [rv] , sub "&undefine" [arg0] [ InsNew tempPMC PerlScalar , arg0 <== tempPMC ] --> [arg0] , vop1ip "&defined" "defined" {- XXX saying hash -- causes error:imcc:syntax error, unexpected IREG, expecting '(' , sub "&id" [arg0] [ InsNew rv PerlScalar , tempINT <-- "hash" $ [arg0] , rv <== tempINT ] --> [rv] -} , vop1 "&clone" "clone" -- Aggregates , 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] -- find_name($arg0 ~ join "::", @arg1) [ tempSTR <-- "join" $ [lit "::", arg1] , tempSTR2 <:= arg0 , tempSTR <-- "concat" $ [tempSTR2, tempSTR] -- XXX: Normalise tempSTR, i.e. "&infix:<+>" -> "&infix:+" , 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"] -- hopefully this is never false , InsLabel "eval_pir_done" , "close" .- [tempPMC] ] --> [rv] ] -- Supporting Math::Basic , sub "&abs" [arg0] [ InsNew rv PerlScalar , rv <== arg0 , "abs" .- [arg0] ] --> [rv] , vop1nn "&exp" "exp" , vop1nn "&ln" "ln" , vop1nn "&log2" "log2" , vop1nn "&log10" "log10" -- also need: rand()? sign()? srand() ? S29 , vop1nn "&sqrt" "sqrt" -- Supporting Math::Trig , vop1 "&sin" "sin" , vop1 "&cos" "cos" -- works as vop1. but not sin(). sigh. , 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" -- also need: cosec, cotan, acosec, acotan, asinh, acosh, atanh, cosech, -- cotanh, asech, acosech, acotanh. S29 -- Supporting unspeced: , vop1nn "&ceil" "ceil" , vop1nn "&floor" "floor" , vop1ii "&fact" "fact" , vop2iii "&gcd" "gcd" , vop2iii "&lcm" "lcm" , vop2nnn "&pow" "pow" -- parrot has no times() , sub "&time" [] [ InsNew rv PerlScalar , tempNUM <-- "time" $ [] , rv <:= tempNUM -- Parrot's time returns seconds since 1970, but Perl 6's time -- returns seconds since 2000, so we've to compensate. , "sub" .- [rv, ExpLit . LitNum $ 946684800] ] --> [rv] --, namespace "Str" , sub "&split" [arg0, arg1] [ InsNew rv PerlScalar , tempSTR <:= arg0 , tempSTR2 <:= arg1 -- special case split("\n",...) to get Test.pm working , "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" -- end of special case , tempPMC <-- "split" $ [tempSTR, tempSTR2] , rv <== tempPMC , InsLabel "split_done" ] --> [rv] , sub "&True" [] [] --> [lit True] , sub "&False" [] [] --> [lit False] --, namespace "bool" -- Namespaces have bugs in both pugs and parrot. , sub "&Bool::True" [] [] --> [lit True] , sub "&Bool::False" [] [] --> [lit False] ] instance YAML Doc where asYAML = asYAML . render instance Typeable Doc where typeOf _ = typeOf () ------------------------------------------------------------------------