Changeset 2944

Timestamp:

05/10/05 21:29:10 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

4498

Message:

* named rules and subrule support.

Location:

src

Files:

• Pugs/AST.hs (modified) (3 diffs)
• Pugs/Embed/Parrot.hsc (modified) (3 diffs)
• Pugs/Parser.hs (modified) (3 diffs)
• Pugs/Prim/Match.hs (modified) (2 diffs)
• pge/PGE-Hs.pbc (modified) (previous)

src/Pugs/AST.hs

@@ -765 +765 @@
 cxtOfSigil '%'  = cxtSlurpyAny
 cxtOfSigil '&'  = CxtItem $ mkType "Code"
+cxtOfSigil '<'  = CxtItem $ mkType "Rule"
 cxtOfSigil x    = internalError $ "cxtOfSigil: unexpected character: " ++ show x
 
@@ -774 +775 @@
 typeOfSigil '%'  = mkType "Hash"
 typeOfSigil '&'  = mkType "Code"
+typeOfSigil '<'  = mkType "Rule"
 typeOfSigil x    = internalError $ "typeOfSigil: unexpected character: " ++ show x
 
@@ -1237 +1239 @@
 newObject (MkType "Code")   = liftSTM $
     fmap codeRef $ newTVar mkSub
+newObject (MkType "Rule") = liftSTM $
+    fmap scalarRef $ newTVar undef
 newObject typ = fail ("Cannot create object: " ++ showType typ)
 

src/Pugs/Embed/Parrot.hsc

@@ -34 +34 @@
     removeFile file
 
-evalPGE :: FilePath -> String -> String -> IO String
-evalPGE path str pattern = do
+evalPGE :: FilePath -> String -> String -> [(String, String)] -> IO String
+evalPGE path str pattern subrules = do
     cmd <- findParrot
     (_, out, err, pid) <- runInteractiveProcess cmd
-        ["run_pge.pbc", str, pattern] (Just path) Nothing 
+        ["run_pge.pbc", str, pattern] ++ concatMap (\(n, r) -> [n, r]) subrules
+        (Just path) Nothing 
     rv      <- waitForProcess pid
     errMsg  <- hGetContents err
@@ -106 +107 @@
     return interp
 
-loadPGE :: ParrotInterp -> FilePath -> IO ParrotPMC
+loadPGE :: ParrotInterp -> FilePath -> IO (ParrotPMC, ParrotPMC)
 loadPGE interp path = do
     ns      <- withCString "PGE::Hs" $ const_string interp
     sym     <- withCString "match" $ const_string interp
-    sub     <- parrot_find_global interp ns sym
-    if sub /= nullPtr then return sub else do
+    match   <- parrot_find_global interp ns sym
+    sym     <- withCString "add_rule" $ const_string interp
+    add     <- parrot_find_global interp ns sym
+    if match /= nullPtr then return (match, add) else do
     pf      <- withCString (path ++ "/PGE-Hs.pbc") $ parrot_readbc interp
     parrot_loadbc interp pf
@@ -117 +120 @@
     loadPGE interp path
 
-evalPGE :: FilePath -> String -> String -> IO String
-evalPGE path str pattern = do
-    interp  <- initParrot
-    sub     <- loadPGE interp path
-    s1      <- withCString str $ const_string interp
-    s2      <- withCString pattern $ const_string interp
-    s5      <- withCString "SSS" $ \sig -> do
-        parrot_call_sub_SSS interp sub sig s1 s2
+evalPGE :: FilePath -> String -> String -> [(String, String)] -> IO String
+evalPGE path str pattern subrules = do
+    interp          <- initParrot
+    (match, add)    <- loadPGE interp path
+    (`mapM_` subrules) $ \(name, rule) -> do
+        s1  <- withCString name $ const_string interp
+        s2  <- withCString rule $ const_string interp
+        withCString "SSS" $ \sig -> do
+            parrot_call_sub_SSS interp add sig s1 s2
+    s1  <- withCString str $ const_string interp
+    s2  <- withCString pattern $ const_string interp
+    s5  <- withCString "SSS" $ \sig -> do
+        parrot_call_sub_SSS interp match sig s1 s2
     peekCString =<< #{peek STRING, strstart} s5
 

src/Pugs/Parser.hs

@@ -200 +200 @@
     [ ruleSubDeclaration
     , ruleClosureTrait False
+    , ruleRuleDeclaration
     ]
 
@@ -249 +250 @@
         ++ (maybe (if null names' then [defaultArrayParam] else []) id formal)
 
+ruleRuleDeclaration :: RuleParser Exp
+ruleRuleDeclaration = rule "rule declaration" $ try $ do
+    symbol "rule"
+    name    <- identifier
+    adverbs <- ruleAdverbHash
+    ch      <- char '{'
+    expr    <- rxLiteralAny adverbs $ balancedDelim ch
+    let exp = Syn ":=" [Var ('<':name), Syn "rx" [expr, adverbs]] -- , bodyPos)
+    unsafeEvalExp (Sym SGlobal ('<':name) exp)
+    return emptyExp
 
 ruleSubDeclaration :: RuleParser Exp
@@ -1502 +1513 @@
     sym     <- symbol "rx" <|> do { symbol "m"; return "match" } <|> do
         symbol "rule"
-        lookAhead (char '{')
+        lookAhead $ do { ruleAdverbHash; char '{' }
         return "rx"
     adverbs <- ruleAdverbHash
     ch      <- anyChar
-    -- XXX - probe for adverbs to determine p5 vs p6
     expr    <- rxLiteralAny adverbs $ balancedDelim ch
     return $ Syn sym [expr, adverbs]

src/Pugs/Prim/Match.hs

@@ -20 +20 @@
     hasSrc <- liftIO $ doesDirectoryExist pwd2
     let pwd = if hasSrc then pwd2 else pwd1
-    pge <- liftIO $ evalPGE pwd (encodeUTF8 cs) (encodeUTF8 re)
+    glob    <- askGlobal
+    let syms = [ (name, tvar) | (('<':name), [(_, tvar)]) <- padToList glob ]
+    subrules <- forM syms $ \(name, tvar) -> do
+        ref  <- liftSTM $ readTVar tvar
+        (VRule rule) <- fromVal =<< readRef ref
+        return (name, rxRule rule)
+    pge <- liftIO $ evalPGE pwd (encodeUTF8 cs) (encodeUTF8 re) subrules
     rv  <- tryIO Nothing $ fmap Just (readIO $ decodeUTF8 pge) 
     let matchToVal PGE_Fail = VMatch mkMatchFail
@@ -32 +38 @@
     case rv of
         Just m  -> fromVal (matchToVal m)
-        Nothing -> fail ("Cannot parse PGE: " ++ pge)
+        Nothing -> do
+            liftIO $ putStrLn ("*** Cannot parse PGE: " ++ re ++ "\n*** Error: " ++ pge)
+            return mkMatchFail
 
 doMatch cs MkRulePCRE{ rxRegex = re } = do