Changeset 10648

Timestamp:

06/12/06 14:32:44 (2 years ago)

Author:

audreyt

Message:

* Unify named and unamed subroutines.

(note - for releng, I'll rollback this thread of changes

and hold until 6.2.12 is released, to investigate more
into the serious perf hit caused by it.)

Location:

src/Pugs

Files:

• Eval.hs (modified) (2 diffs)
• Lexer.hs (modified) (1 diff)
• Parser.hs (modified) (14 diffs)

src/Pugs/Eval.hs

@@ -350 +350 @@
     enterLex [sym] $ evalExp exp
 
-reduceSym scope name exp | scope <= SMy = do
+reduceSym scope name exp | scope < SGlobal = do
     ref <- newObject (typeOfSigil $ head name)
     let (gen, name') = case name of
@@ -356 +356 @@
             _               -> (genSym, name)
     sym <- gen name' ref
+    when (scope == SOur) $ do
+        qn  <- toQualified name'
+        addGlobalSym =<< gen qn ref
     enterLex [ sym ] $ evalExp exp
 

src/Pugs/Lexer.hs

@@ -386 +386 @@
 
 ruleBareTrait :: String -> RuleParser String
-ruleBareTrait trait = rule "bare trait" $ do
+ruleBareTrait trait = tryRule "bare trait" $ do
     choice [ ruleTraitName trait
            , do symbol trait

src/Pugs/Parser.hs

@@ -159 +159 @@
     ]
 
-ruleSubHead :: RuleParser (Bool, SubType, String)
-ruleSubHead = rule "subroutine head" $ do
-    isMulti <- option False $ do { symbol "multi" ; return True }
-    -- You're allowed to omit the "sub":
-    --   multi sub foo (...) {...}      # legal
-    --         sub foo (...) {...}      # legal, too
-    let implicitSub | isMulti == True = return SubRoutine
-                    | otherwise       = pzero
-    styp    <- choice
-        [ do symbol "sub"
-             return SubRoutine
-        , do symbol "coro"
-             return SubCoroutine
-        , do (symbol "submethod" <|> symbol "method")
-             return SubMethod
-        , do symbol "macro"
-             return SubMacro
-        ] <|> implicitSub
-    name    <- ruleSubName
-    return (isMulti, styp, name)
-
--- | Scope, context, isMulti, styp, name
-type SubDescription = (Scope, String, Bool, SubType, String)
-
-ruleSubScopedWithContext :: RuleParser SubDescription
-ruleSubScopedWithContext = tryRule "scoped subroutine with context" $ do
-    scope   <- ruleScope
-    cxt     <- identifier
-    (isMulti, styp, name) <- ruleSubHead
-    return (scope, cxt, isMulti, styp, name)
-
-ruleSubScoped :: RuleParser SubDescription
-ruleSubScoped = tryRule "scoped subroutine" $ do
-    scope <- ruleScope
-    (isMulti, styp, name) <- ruleSubHead
-    return (scope, "Any", isMulti, styp, name)
-
-ruleSubGlobal :: RuleParser SubDescription
-ruleSubGlobal = tryRule "global subroutine" $ do
-    (isMulti, styp, name) <- ruleSubHead
-    return (SGlobal, "Any", isMulti, styp, name)
-
 ruleRuleDeclaration :: RuleParser Exp
 ruleRuleDeclaration = rule "rule declaration" $ do
@@ -251 +209 @@
         Nothing   -> return name
         _         -> fail "I only know about package- and global-scoped classes. Sorry."
-    traits  <- many $ ruleTrait
+    traits  <- many ruleTrait
     let pkgClass = case sym of
                        "package" -> "Package"
@@ -274 +232 @@
                 kind   = Val . VStr $ sym
             return $ Right (newName, kind, pkgVal, env)
-
-ruleSubDeclaration :: RuleParser Exp
-ruleSubDeclaration = rule "subroutine declaration" $ do
-    namePos <- getPosition
-    (scope, typ, isMulti, styp, name) <- choice
-        [ ruleSubScopedWithContext
-        , ruleSubScoped
-        , ruleSubGlobal
-        ]
-    optional $ do { symbol "handles"; ruleExpression }
-    typ'    <- option typ $ try $ ruleBareTrait "returns"
-    formal  <- option Nothing $ ruleSubParameters ParensMandatory
-    typ''   <- option typ' $ try $ ruleBareTrait "returns"
-    traits  <- many $ ruleTrait
-
-    -- XXX - We have the prototype now; install it immediately?
-
-    -- bodyPos <- getPosition
-    body    <- ruleBlockWithParams (maybe [] id formal)
-    let (fun, names, params) = doExtract styp formal body
-    -- Check for placeholder vs formal parameters
-    when (isJust formal && (not.null) names) $
-        fail "Cannot mix placeholder variables with formal parameters"
-    env <- ask
-    let sub = VCode $ MkCode
-            { isMulti       = isMulti
-            , subName       = nameQualified
-            , subEnv        = Just env
-            , subType       = if "primitive" `elem` traits
-                then SubPrim else styp
-            , subAssoc      = "pre"
-            , subReturns    = mkType typ''
-            , subLValue     = "rw" `elem` traits
-            , subParams     = self ++ paramsFor styp formal params
-            , subBindings   = []
-            , subSlurpLimit = []
-            , subBody       = fun
-            , subCont       = Nothing
-            }
-        pkg = envPackage env
-        nameQualified | ':' `elem` name     = name
-                      | scope <= SMy        = name
-                      | isGlobal            = name
-                      | isBuiltin           = (head name:'*':tail name)
-                      | otherwise           = (head name:pkg) ++ "::" ++ tail name
-        self :: [Param]
-        self | styp > SubMethod = []
-             | (prm:_) <- params, isInvocant prm = []
-             | otherwise = [selfParam $ envPackage env]
-        mkExp n = Syn ":=" [Var n, Syn "sub" [Val sub]]
-        mkSym n = Sym scope (mkMulti n) (mkExp n)
-        mkSymGlobal globalName lexicalName = Stmts
-            (Sym SMy (mkMulti lexicalName) (mkExp lexicalName))
-            (Sym SGlobal (mkMulti globalName) (Syn ":=" [Var globalName, Var lexicalName]))
-        -- Horrible hack! Sym "&&" is the multi form.
-        mkMulti | isMulti   = ('&':)
-                | otherwise = id
-        isGlobal = '*' `elem` name
-        isBuiltin = ("builtin" `elem` traits)
-        isExported = ("export" `elem` traits)
-        isScopeGlobal = case scope of
-            SGlobal -> True
-            SOur    -> True
-            _       -> False
-        expMakeSym
-            | isScopeGlobal = mkSymGlobal nameQualified name
-            | otherwise     = mkSym nameQualified
-        expImmediate
-            | isExported    = Stmts expMakeSym $ 
-                (App (Var "&push")
-                    (Just (Syn "{}" [Var ("%" ++ pkg ++ "::EXPORTS"), Val $ VStr name]))
-                    [Var name])
-            | otherwise     = expMakeSym
-        
-    -- XXX this belongs in semantic analysis, not in the parser
-    -- also, maybe we should only warn when you try to export an
-    -- operator that is "standard"
-    -- XXX I can't figure out how to do this without trace
-    when (isExported && isOperatorName name) $
-        trace 
-            ("You probably don't want to export an operator name; instead\n\
-  define a new variant on the new operator (eg. multi sub *infix:<+>): "
-                ++ show name ++ " at " ++ show namePos)
-            (return ())
-            
-    -- Don't add the sub if it's unsafe and we're in safemode.
-    if "unsafe" `elem` traits && safeMode then return emptyExp else do
-    lexDiff <- unsafeEvalLexDiff expImmediate
-    addBlockPad SMy lexDiff
-    clearDynParsers
-    return (Var name)
 
 ruleSubNamePossiblyWithTwigil :: RuleParser String
@@ -482 +349 @@
                     -> return (x:'!':xs)
         _           -> fail $ "Invalid member variable name '" ++ attr ++ "'"
-    traits  <- many $ ruleTrait
+    traits  <- many ruleTrait
     optional $ do { symbol "handles"; ruleExpression }
     env     <- ask
@@ -1167 +1034 @@
     exp <- ruleExpression
     return $ \body -> do
-        block <- retBlock SubBlock Nothing False body
+        block <- retBlock SubBlock Nothing Nothing [] body
         return $ Syn cond [exp, block]
 
@@ -1176 +1043 @@
 ruleBlockLiteral :: RuleParser Exp
 ruleBlockLiteral = rule "block construct" $
-    ruleBlockVariants [ ruleBlockFormalPointy, ruleBlockFormalStandard ]
-
-ruleBlockVariants :: [RuleParser (SubType, Maybe [Param], Bool)] -> RuleParser Exp
+    ruleBlockVariants [ ruleBlockFormalPointy, ruleSubHead ]
+
+ruleBlockVariants :: [RuleParser SubDescription] -> RuleParser Exp
 ruleBlockVariants variants = do
-    (typ, formal, lvalue) <- option (SubBlock, Nothing, False)
+    (isMulti, typ, maybeName, formal, traits) <- option (False, SubBlock, Nothing, Nothing, [])
         $ choice variants
     body    <- ruleBlockWithParams (maybe [] id formal)
-    retBlock typ formal lvalue body
-
-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
+    rv      <- retBlock typ maybeName formal traits body
+    case maybeName of
+        Just name   -> registerSubName isMulti SOur name traits rv
+        _           -> return rv
+
+registerSubName :: Bool -> Scope -> Var -> Traits -> Exp -> RuleParser Exp
+registerSubName isMulti scope name traits exp = do
+    -- Don't add the sub if it's unsafe and we're in safemode.
+    if "unsafe" `elem` traits && safeMode then return emptyExp else do
+    lexDiff <- unsafeEvalLexDiff $
+        Sym scope ((if isMulti then ('&':) else id) name) emptyExp
+    addBlockPad scope lexDiff
+    rv  <- unsafeEvalExp $! Syn ":=" [Var name, exp]
+    pkg <- asks envPackage
+    when (scope == SOur || scope == SGlobal) $ do
+        let qualifiedName = (head name:pkg) ++ (':':':':tail name)
+        unsafeEvalExp $! Syn ":=" [Var qualifiedName, rv]
+        return ()
+    when ("export" `elem` traits) $ do
+        when (isOperatorName name) $ do
+            namePos <- getPosition
+            trace ("You probably don't want to export an operator name; instead\n\
+    define a new variant on the new operator (eg. multi sub *infix:<+>): "
+                    ++ show name ++ " at " ++ show namePos)
+                (return ())
+        unsafeEvalExp $!
+            App (Var "&push")
+                (Just (Syn "{}" [Var ("%" ++ pkg ++ "::EXPORTS"), Val $ VStr name]))
+                [rv]
+        return ()
+    -- Now handle exports and push the sub into namedness
+    return rv
+
+retBlock :: SubType -> Maybe Var -> Maybe [Param] -> Traits -> Exp -> RuleParser Exp
+retBlock SubBlock _ Nothing _ exp | Just hashExp <- extractHash (unwrap exp) = return $ Syn "\\{}" [hashExp]
+retBlock typ maybeName formal traits body = retVerbatimBlock typ maybeName formal traits body
+
+retVerbatimBlock :: SubType -> Maybe Var -> Maybe [Param] -> Traits -> Exp -> RuleParser Exp
+retVerbatimBlock styp maybeName formal traits body = expRule $ do
     let (fun, names, params) = doExtract styp formal body
     -- Check for placeholder vs formal parameters
@@ -1198 +1096 @@
     let sub = MkCode
             { isMulti       = False
-            , subName       = "<anon>"
+            , subName       = maybe "<anon>" qualify maybeName
             , subEnv        = Just env
-            , subType       = styp
+            , subType       = if "primitive" `elem` traits
+                then SubPrim else styp
             , subAssoc      = "pre"
             , subReturns    = anyType
-            , subLValue     = lvalue
-            , subParams     = paramsFor styp formal params
+            , subLValue     = "rw" `elem` traits
+            , subParams     = self ++ paramsFor styp formal params
             , subBindings   = []
             , subSlurpLimit = []
@@ -1210 +1109 @@
             , subCont       = Nothing
             }
+        pkg = envPackage env
+        qualify name | ':' `elem` name     = name
+                     | '*' `elem` name     = name
+                     | isBuiltin           = (head name:'*':tail name)
+                     | otherwise           = (head name:pkg) ++ "::" ++ tail name
+        self :: [Param]
+        self | styp > SubMethod = []
+             | (prm:_) <- params, isInvocant prm = []
+             | otherwise = [selfParam $ envPackage env]
+        isBuiltin = "builtin" `elem` traits
     return (Syn "sub" [Val $ VCode sub])
 
-ruleBlockFormalStandard :: RuleParser (SubType, Maybe [Param], Bool)
-ruleBlockFormalStandard = rule "standard block parameters" $ do
-    styp <- choice
-        [ do { symbol "sub";   return SubRoutine }
-        , do { symbol "coro";  return SubCoroutine }
-        , do { symbol "macro"; return SubMacro }
-        ]
+type Traits = [String]
+
+type IsMulti = Bool
+type MaybeName = Maybe Var
+type SubDescription = (IsMulti, SubType, MaybeName, Maybe [Param], Traits)
+
+ruleSubHead :: RuleParser SubDescription
+ruleSubHead = rule "subroutine head" $ do
+    isMulti <- option False $ do { symbol "multi" ; return True }
+    -- You're allowed to omit the "sub":
+    --   multi sub foo (...) {...}      # legal
+    --         sub foo (...) {...}      # legal, too
+    let implicitSub | isMulti == True = return SubRoutine
+                    | otherwise       = pzero
+    styp    <- choice
+        [ do symbol "sub"
+             return SubRoutine
+        , do symbol "coro"
+             return SubCoroutine
+        , do (symbol "submethod" <|> symbol "method")
+             return SubMethod
+        , do symbol "macro"
+             return SubMacro
+        ] <|> implicitSub
+    name   <- option Nothing $ fmap Just (lexeme ruleSubName)
     params <- option Nothing $ ruleSubParameters ParensMandatory
-    traits <- many $ ruleTrait
-    return $ (styp, params, "rw" `elem` traits)
-
-ruleBlockFormalPointy :: RuleParser (SubType, Maybe [Param], Bool)
+    optional $ ruleBareTrait "returns"
+    traits <- many ruleTrait
+    optional $ ruleBareTrait "returns"
+    return (isMulti, styp, name, params, traits)
+
+ruleBlockFormalPointy :: RuleParser SubDescription
 ruleBlockFormalPointy = rule "pointy block parameters" $ do
     symbol "->"
     params <- ruleSubParameters ParensOptional
-    traits <- many $ ruleTrait
-    return $ (SubPointy, params, "rw" `elem` traits)
+    optional $ ruleBareTrait "returns"
+    traits <- many ruleTrait
+    optional $ ruleBareTrait "returns"
+    return $ (False, SubPointy, Nothing, params, traits)
 
 
@@ -1269 +1200 @@
 parseExpWithItemOps = parseExpWithCachedParser dynParseLitOp
 
-ruleVarDecl :: RuleParser Exp
-ruleVarDecl = rule "variable declaration" $ do
+ruleScopedRoutine :: Scope -> SubDescription -> RuleParser Exp
+ruleScopedRoutine scope (isMulti, styp, maybeName, params, traits) = do
+    body    <- ruleBlockWithParams $ maybe [] id params
+    rv      <- retBlock styp maybeName params traits body
+    case maybeName of
+        Just name   -> registerSubName isMulti scope name traits rv
+        _           -> return rv
+
+ruleScopedDeclaration :: RuleParser Exp
+ruleScopedDeclaration = rule "variable declaration" $ do
     scope           <- ruleScope
-    (cxtNames, exp) <- oneDecl <|> manyDecl
-    let makeBinding (nam, cxt)
-            | typ == anyType    = mkSym
-            | otherwise         = mkSym . bindSym
-            where
-            mkSym   = Sym scope nam
-            bindSym = Stmts (Syn "=" [Var nam, Val (VType typ)])
-            typ     = typeOfCxt cxt
-    lexDiff <- unsafeEvalLexDiff $ combine (map makeBinding cxtNames) emptyExp
-    -- Now hoist the lexDiff to the current block
-    addBlockPad scope lexDiff
-    return exp
+    (ruleSubHead >>= ruleScopedRoutine scope) <|> do
+        (cxtNames, exp) <- oneDecl <|> manyDecl
+        let makeBinding (name, cxt)
+                | ('$':_) <- name, typ /= anyType   = mkSym . bindSym
+                | otherwise                         = mkSym
+                where
+                mkSym   = Sym scope name
+                bindSym = Stmts (Syn "=" [Var name, Val (VType typ)])
+                typ     = typeOfCxt cxt
+        lexDiff <- unsafeEvalLexDiff $ combine (map makeBinding cxtNames) emptyExp
+        -- Now hoist the lexDiff to the current block
+        addBlockPad scope lexDiff
+        return exp
     where
     deSigil (sig:'!':rest@(_:_)) = (sig:rest)
@@ -1302 +1242 @@
 parseTerm = rule "term" $ do
     term <- choice
-        [ ruleSubDeclaration
-        , ruleDereference
-        , ruleVarDecl
+        [ ruleDereference
+        , ruleScopedDeclaration
         , ruleVar
         , ruleApply True    -- Folded metaoperators
         , ruleLit
---      , ruleBarewordMethod
         , ruleClosureTrait True
         , ruleCodeQuotation
         , ruleTypeVar
---      , ruleTypeLiteral
         , ruleApply False   -- Normal application
         , verbatimParens ruleBracketedExpression
@@ -1323 +1260 @@
             fs <- many rulePostTerm
             return (combine (reverse fs) term)
-
-{-
-ruleBarewordMethod :: RuleParser Exp
-ruleBarewordMethod = try $ do
-    name <- identifier
-    lookAhead (char '.' >> ruleSubName)
-    return $ Var (':':name)
--}
 
 ruleTypeVar :: RuleParser Exp
@@ -1471 +1400 @@
         then ruleFoldOp
         else ruleSubNameWithoutPostfixModifier
-
     (paramListInv, args) <- choice $
         [ (ruleDot `tryLookAhead` char '(') >> parseHasParenParamList
@@ -1479 +1407 @@
         ]
     possiblyApplyMacro $ App (Var name) paramListInv args
-{-
-    -- True for `foo. .($bar)`-style applications
-    let takeArguments = do
-            (paramListInv, args) <- choice $
-                [ (ruleDot `tryLookAhead` char '(') >> parseHasParenParamList
-                , parseParenParamList
-                , mandatoryWhiteSpace >> parseNoParenParamList
-                ] ++ (if isFolded then [return (Nothing, [])] else [])
-            possiblyApplyMacro $ App (Var name) paramListInv args
-    takeArguments
-        <|> possiblyTypeLiteral name
-        <|> possiblyApplyMacro (App (Var name) Nothing [])
--}
 
 ruleFoldOp :: RuleParser String
@@ -1694 +1609 @@
 ruleSigiledVar = (<|> ruleSymbolicDeref) $ do
     name <- ruleVarNameString
-    let (sigil, rest) = span (`elem` "$@%&:^") name
+    let (sigil, rest) = span (`elem` "$@%&:") name
     case rest of
         []                              -> return (makeVar name)