Changeset 6424

Timestamp:

08/23/05 22:18:24 (3 years ago)

Author:

iblech

Message:

* Pugs.PIL1: Added pSubLValue/pLValue to PSub and PCode, indicating the

difference between "sub foo {...}" and "sub foo is rw {...}".

* Pugs.Compile: Extract the (subLValue vcode) and put in in the appropriate

field of PSub/PCode.

* Pugs.CodeGen?.PIR: Accomodate for the above changes.
* Pugs.Parser: Parse traits for anonymous subs, too (i.e. "sub () is rw

{...}" parses and works now).

Location:

src/Pugs

Files:

• CodeGen/PIR.hs (modified) (4 diffs)
• Compile.hs (modified) (6 diffs)
• PIL1.hs (modified) (7 diffs)
• PIL1.hs-drift (modified) (2 diffs)
• Parser.hs (modified) (6 diffs)

src/Pugs/CodeGen/PIR.hs

@@ -106 +106 @@
         tellLabel endL
         return (ExpLV this)
-    trans (PCode styp params body) = do
+    trans (PCode styp params _ body) = do
         [begL, endL] <- genLabel ["blockBegin", "blockEnd"]
         this    <- genPMC "block"
@@ -126 +126 @@
 
 instance Translate PIL_Decl Decl where
-    trans (PSub name styp params body) | Just (pkg, name') <- isQualified name = do
-        declC <- trans $ PSub name' styp params body
+    trans (PSub name styp params lvalue body) | Just (pkg, name') <- isQualified name = do
+        declC <- trans $ PSub name' styp params lvalue body
         return $ DeclNS pkg [declC]
-    trans (PSub name styp params body) = do
+    trans (PSub name styp params _ body) = do
         (_, stmts)  <- listen $ do
             let prms = map tpParam params
@@ -186 +186 @@
         tellIns $ lhsC <:= rhsC
         return lhsC
-    trans (PApp _ exp@(PCode _ _ _) Nothing []) = do
+    trans (PApp _ exp@(PCode _ _ _ _) Nothing []) = do
         blockC  <- trans exp
         tellIns $ [reg tempPMC] <-& blockC $ []
@@ -383 +383 @@
             , InsNew tempPMC PerlScalar
             , "store_global"    .- [lit "$_", tempPMC]
-            ]) ++ [ StmtRaw (text (name ++ "()")) | PSub name@('_':'_':_) _ _ _ <- pilGlob penv ] ++
+            ]) ++ [ StmtRaw (text (name ++ "()")) | PSub name@('_':'_':_) _ _ _ _ <- pilGlob penv ] ++
             [ StmtRaw (text "main()")
             , StmtIns $ tempPMC  <-- "find_global" $ [lit "Perl6::Internals", lit "&exit"]

src/Pugs/Compile.hs

@@ -105 +105 @@
                 name' | ':' `elem` name = name
                       | otherwise = "main::" ++ name -- XXX wrong
-            return [PSub initL SubPrim [] bodyC]
+            return [PSub initL SubPrim [] False bodyC]
         canCompile _ = return []
         doCode name vsub = case subBody vsub of
@@ -117 +117 @@
     compile (name, decls) = do
         let bodyC = [ PStmts . PStmt . PExp $ PApp tcVoid (PExp (PVar sub)) Nothing []
-                    | PSub sub _ _ _ <- decls
+                    | PSub sub _ _ _ _ <- decls
                     ]
-        return (PSub name SubPrim [] (combine bodyC PNil):decls)
+        return (PSub name SubPrim [] False (combine bodyC PNil):decls)
 
 instance Compile (SubName, VCode) [PIL_Decl] where
@@ -126 +126 @@
             bodyC   = PStmts (PStmt . PExp $ storeC) PNil
             exportL = "__export_" ++ (render $ varText name)
-        return [PSub exportL SubPrim [] bodyC]
+        return [PSub exportL SubPrim [] False bodyC]
     compile (name, vsub) = do
         bodyC   <- enter cxtItemAny . compile $ case subBody vsub of
@@ -132 +132 @@
             body                -> body
         paramsC <- compile $ subParams vsub
-        return [PSub name (subType vsub) paramsC bodyC]
+        return [PSub name (subType vsub) paramsC (subLValue vsub) bodyC]
 
 instance Compile (String, [(TVar Bool, TVar VRef)]) PIL_Expr where
@@ -228 +228 @@
 
 pBlock :: PIL_Stmts -> PIL_Expr
-pBlock = PCode SubBlock []
+pBlock = PCode SubBlock [] False
 
 {-
@@ -356 +356 @@
             exp                 -> exp
         paramsC <- compile $ subParams sub
-        return $ PCode (subType sub) paramsC bodyC
+        return $ PCode (subType sub) paramsC (subLValue sub) bodyC
     compile (Syn "module" _) = compile Noop
     compile (Syn "match" exp) = compile $ Syn "rx" exp -- wrong

src/Pugs/PIL1.hs

@@ -72 +72 @@
         { pType    :: !SubType
         , pParams  :: ![TParam]
+        , pLValue  :: !Bool
         , pBody    :: !PIL_Stmts
         }
@@ -80 +81 @@
     , pSubType      :: !SubType
     , pSubParams    :: ![TParam]
+    , pSubLValue    :: !Bool
     , pSubBody      :: !PIL_Stmts
     }
@@ -256 +258 @@
             putByte bh 3
             put_ bh ad
-    put_ bh (PCode ae af ag) = do
+    put_ bh (PCode ae af ag ah) = do
             putByte bh 4
             put_ bh ae
             put_ bh af
             put_ bh ag
+            put_ bh ah
     get bh = do
             h <- getByte bh
@@ -280 +283 @@
                     af <- get bh
                     ag <- get bh
-                    return (PCode ae af ag)
+                    ah <- get bh
+                    return (PCode ae af ag ah)
 
 instance Perl5 PIL_Expr where
@@ -289 +293 @@
     showPerl5 (PThunk aa) = showP5HashObj "PThunk"
               [("pThunk", showPerl5 aa)]
-    showPerl5 (PCode aa ab ac) = showP5HashObj "PCode"
+    showPerl5 (PCode aa ab ac ad) = showP5HashObj "PCode"
               [("pType", showPerl5 aa) , ("pParams", showPerl5 ab) ,
-               ("pBody", showPerl5 ac)]
+               ("pLValue", showPerl5 ac) , ("pBody", showPerl5 ad)]
 
 instance JSON PIL_Expr where
@@ -300 +304 @@
     showJSON (PThunk aa) = showJSHashObj "PThunk"
              [("pThunk", showJSON aa)]
-    showJSON (PCode aa ab ac) = showJSHashObj "PCode"
+    showJSON (PCode aa ab ac ad) = showJSHashObj "PCode"
              [("pType", showJSON aa) , ("pParams", showJSON ab) ,
-              ("pBody", showJSON ac)]
+              ("pLValue", showJSON ac) , ("pBody", showJSON ad)]
 
 instance Binary PIL_Decl where
-    put_ bh (PSub aa ab ac ad) = do
-            put_ bh aa
-            put_ bh ab
-            put_ bh ac
-            put_ bh ad
+    put_ bh (PSub aa ab ac ad ae) = do
+            put_ bh aa
+            put_ bh ab
+            put_ bh ac
+            put_ bh ad
+            put_ bh ae
     get bh = do
     aa <- get bh
@@ -315 +320 @@
     ac <- get bh
     ad <- get bh
-    return (PSub aa ab ac ad)
+    ae <- get bh
+    return (PSub aa ab ac ad ae)
 
 instance Perl5 PIL_Decl where
-    showPerl5 (PSub aa ab ac ad) = showP5HashObj "PSub"
+    showPerl5 (PSub aa ab ac ad ae) = showP5HashObj "PSub"
               [("pSubName", showPerl5 aa) , ("pSubType", showPerl5 ab) ,
-               ("pSubParams", showPerl5 ac) , ("pSubBody", showPerl5 ad)]
+               ("pSubParams", showPerl5 ac) , ("pSubLValue", showPerl5 ad) ,
+               ("pSubBody", showPerl5 ae)]
 
 instance JSON PIL_Decl where
-    showJSON (PSub aa ab ac ad) = showJSHashObj "PSub"
+    showJSON (PSub aa ab ac ad ae) = showJSHashObj "PSub"
              [("pSubName", showJSON aa) , ("pSubType", showJSON ab) ,
-              ("pSubParams", showJSON ac) , ("pSubBody", showJSON ad)]
+              ("pSubParams", showJSON ac) , ("pSubLValue", showJSON ad) ,
+              ("pSubBody", showJSON ae)]
 
 instance Binary PIL_Literal where

src/Pugs/PIL1.hs-drift

@@ -70 +70 @@
         { pType    :: !SubType
         , pParams  :: ![TParam]
+        , pLValue  :: !Bool
         , pBody    :: !PIL_Stmts
         }
@@ -78 +79 @@
     , pSubType      :: !SubType
     , pSubParams    :: ![TParam]
+    , pSubLValue    :: !Bool
     , pSubBody      :: !PIL_Stmts
     }

src/Pugs/Parser.hs

@@ -98 +98 @@
 ruleStandaloneBlock = tryRule "standalone block" $ do
     body <- bracesAlone ruleBlockBody
-    retBlock SubBlock Nothing body
+    retBlock SubBlock Nothing False body
     where
     bracesAlone p  = between (symbol "{") closingBrace p
@@ -1017 +1017 @@
     exp <- ruleExpression
     return $ \body -> do
-        block <- retBlock SubBlock Nothing body
+        block <- retBlock SubBlock Nothing False body
         retSyn cond [exp, block]
 
 ruleBlockLiteral :: RuleParser Exp
 ruleBlockLiteral = rule "block construct" $ do
-    (typ, formal) <- option (SubBlock, Nothing) $ choice
+    (typ, formal, lvalue) <- option (SubBlock, Nothing, False) $ choice
         [ ruleBlockFormalPointy
         , ruleBlockFormalStandard
         ]
     body <- ruleBlock
-    retBlock typ formal body
+    retBlock typ formal lvalue body
 
 extractHash :: Exp -> Maybe Exp
@@ -1037 +1037 @@
 extractHash _ = Nothing
 
-retBlock :: SubType -> Maybe [Param] -> Exp -> RuleParser Exp
-retBlock SubBlock Nothing exp | Just hashExp <- extractHash (unwrap exp) = return $ Syn "\\{}" [hashExp]
-retBlock typ formal body = retVerbatimBlock typ formal body
-
-retVerbatimBlock :: SubType -> Maybe [Param] -> Exp -> RuleParser Exp
-retVerbatimBlock styp formal body = expRule $ do
+retBlock :: SubType -> Maybe [Param] -> Bool -> Exp -> RuleParser Exp
+retBlock SubBlock Nothing _ exp | Just hashExp <- extractHash (unwrap exp) = return $ Syn "\\{}" [hashExp]
+retBlock typ formal lvalue body = retVerbatimBlock typ formal lvalue body
+
+retVerbatimBlock :: SubType -> Maybe [Param] -> Bool -> Exp -> RuleParser Exp
+retVerbatimBlock styp formal lvalue body = expRule $ do
     let (fun, names, params) = doExtract styp formal body
     -- Check for placeholder vs formal parameters
@@ -1055 +1055 @@
             , subAssoc      = "pre"
             , subReturns    = anyType
-            , subLValue     = False -- XXX "is rw"
+            , subLValue     = lvalue
             , subParams     = paramsFor styp formal params
             , subBindings   = []
@@ -1076 +1076 @@
 defaultParamFor _           = [defaultArrayParam]
 
-ruleBlockFormalStandard :: RuleParser (SubType, Maybe [Param])
+ruleBlockFormalStandard :: RuleParser (SubType, Maybe [Param], Bool)
 ruleBlockFormalStandard = rule "standard block parameters" $ do
     styp <- choice
@@ -1084 +1084 @@
         ]
     params <- option Nothing $ ruleSubParameters ParensMandatory
-    return $ (styp, params)
-
-ruleBlockFormalPointy :: RuleParser (SubType, Maybe [Param])
+    traits <- many $ ruleTrait
+    return $ (styp, params, "rw" `elem` traits)
+
+ruleBlockFormalPointy :: RuleParser (SubType, Maybe [Param], Bool)
 ruleBlockFormalPointy = rule "pointy block parameters" $ do
     symbol "->"
     params <- ruleSubParameters ParensOptional
-    return $ (SubPointy, params)
+    traits <- many $ ruleTrait
+    return $ (SubPointy, params, "rw" `elem` traits)