Changeset 8

Timestamp:

02/11/05 08:54:56 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

1041

Message:

* checkin.

Files:

• ChangeLog (modified) (1 diff)
• src/AST.hs (modified) (6 diffs)
• src/Bind.hs (added)
• src/Eval.hs (modified) (6 diffs)
• src/Internals.hs (modified) (2 diffs)
• src/Lexer.hs (modified) (3 diffs)
• src/Parser.hs (modified) (6 diffs)
• src/Pretty.hs (modified) (1 diff)
• src/Prim.hs (modified) (5 diffs)

ChangeLog

@@ +1 @@
+[Changes for 6.0.2 - February 9, 2005]
+
+* User-defined subroutine (with $_ and @_ as parameters)
+* Variable binding
+* Context propagation
+* Multimethod dispatch
+* Subtype distancing and casting
+* Autothreading over chained comparison and multiarg functions
+* List associativity
+* Array references as literals
+* Flattening (slurpy) star
+
 [Changes for 6.0.1 - February 7, 2005]
 

src/AST.hs

@@ -26 +26 @@
     vCast (VRef v)      = vCast v
     vCast (VPair _ v)   = vCast v
+    vCast (VArray (MkArray v))    = vCast $ VList v
     vCast v             = doCast v
     castV :: n -> Val
@@ -33 +34 @@
     fmapVal :: (n -> n) -> Val -> Val
     fmapVal f = castV . f . vCast
+
+instance Context (Val, Val) where
+    castV (x, y)        = VPair x y
+    vCast (VPair x y)   = (x, y)
+    vCast (VRef v)      = vCast v
+    vCast v             = case vCast v of
+        [x, y]  -> (x, y)
+        other   -> error $ "cannot cast into (Val, Val): " ++ (show v)
+
+instance Context VHash where
+    castV = VHash
+    vCast x = MkHash $ listToFM (map vCast $ vCast x) 
 
 instance Context VSub where
@@ -107 +120 @@
     where
     str = show x 
+
+instance Context VArray where
+    castV = VArray
+    vCast x = MkArray (vCast x) 
 
 instance Context VList where
@@ -186 +203 @@
     deriving (Show, Eq, Ord)
 
-data SubType = SubMethod | SubRoutine | SubMulti
-    deriving (Show, Eq, Ord)
+data SubType = SubMethod | SubRoutine | SubBlock
+    deriving (Show, Eq, Ord)
+
+data Param = Param
+    { isInvocant    :: Bool
+    , isSlurpy      :: Bool
+    , isOptional    :: Bool
+    , isNamed       :: Bool
+    , paramName     :: String
+    , paramContext  :: Cxt
+    , paramDefault  :: Exp
+    }
+    deriving (Show, Eq, Ord)
+
+type Params = [Param]
 
 data VSub = Sub
-    { subType       :: SubType
+    { isMulti       :: Bool
+    , subType       :: SubType
     , subAssoc      :: String
-    , subParams     :: [Cxt]
+    , subParams     :: Params
     , subReturns    :: Cxt
     , subFun        :: Exp
@@ -214 +245 @@
 
 data Exp
-    = App String [Exp]
+    = App String [Exp] [Exp]
     | Syn String [Exp]
     | Prim ([Val] -> Val)
@@ -223 +254 @@
     deriving (Show, Eq, Ord)
 
-isTotalJunc (VJunc JAll _, b)   = not b
-isTotalJunc (VJunc JNone _, b)  = not b
-isTotalJunc _                   = False
-
-isPartialJunc (VJunc JOne _, b) = not b
-isPartialJunc (VJunc JAny _, b) = not b
-isPartialJunc _                 = False
-
+extractExp :: Exp -> ([Exp], [String]) -> ([Exp], [String])
+extractExp exp (exps, vs) = (exp':exps, vs')
+    where
+    (exp', vs') = extract (exp, vs)
+
+extract :: (Exp, [String]) -> (Exp, [String])
+extract ((App n invs args), vs) = (App n invs' args', vs'')
+    where
+    (invs', vs')  = foldr extractExp ([], vs) invs
+    (args', vs'') = foldr extractExp ([], vs') args
+extract ((Syn n exps), vs) = (Syn n exps', vs')
+    where
+    (exps', vs') = foldr extractExp ([], vs) exps
+extract ((Var name pos), vs)
+    | (sigil:'^':identifer) <- name
+    , name' <- (sigil : identifer)
+    = (Var name' pos, insert name' vs)
+    | name == "$_"
+    = (Var name pos, insert name vs)
+    | otherwise
+    = (Var name pos, vs)
+extract ((Parens exp), vs) = ((Parens exp'), vs')
+    where
+    (exp', vs') = extract (exp, vs)
+extract other = other
+
+cxtOf '*' '$'   = "List"
+cxtOf '*' '@'   = "List"
+cxtOf _   _     = "Scalar"
+
+buildParam cxt sigil name exp = Param
+    { isInvocant    = False
+    , isSlurpy      = (sigil == "*")
+    , isOptional    = (sigil ==) `any` ["?", "+"]
+    , isNamed       = (null sigil || head sigil /= '+')
+    , paramName     = name
+    , paramContext  = if null cxt then defaultCxt else cxt
+    , paramDefault  = exp
+    }
+    where
+    sig = if null sigil then ' ' else head sigil
+    defaultCxt = cxtOf sig (head name) 
+
+defaultArrayParam   = buildParam "" "*" "@_" (Val VUndef)
+defaultHashParam    = buildParam "" "*" "%_" (Val VUndef)
+defaultScalarParam  = buildParam "" "*" "$_" (Val VUndef)

src/Eval.hs

@@ -16 +16 @@
 
 import AST
+import Bind
 import Prim
 import Context
@@ -59 +60 @@
     = Nothing
 
-applyFun :: Env -> Exp -> [Val] -> Val
-applyFun env (Prim f) vals = f vals
-applyFun env body vals
+chainFun :: Env -> Params -> Exp -> Params -> Exp -> [Val] -> Val
+chainFun env p1 f1 p2 f2 (v1:v2:vs)
+    | VBool False <- applyFun env (chainArgs p1 [v1, v2]) f1
+    = VBool False
+    | otherwise
+    = applyFun env (chainArgs p1 (v2:vs)) f2
+    where
+    chainArgs prms vals = map chainArg (prms `zip` vals)
+    chainArg (p, v) = ApplyArg (paramName p) v False
+
+data ApplyArg = ApplyArg
+    { argName       :: String
+    , argValue      :: Val
+    , argCollapsed  :: Bool
+    }
+    deriving (Show, Eq, Ord)
+
+applyFun :: Env -> [ApplyArg] -> Exp -> Val
+applyFun env bound (Prim f) = f [ argValue arg | arg <- bound, (argName arg !! 1) /= '_' ]
+applyFun env bound body
     | Val val   <- exp          = val
     | otherwise                 = VError "Invalid expression" exp
     where
-    (fenv, exp) = reduce (env `addSym` [("$_", head vals),("@_", VList vals)]) body
-
-chainFun :: Env -> Exp -> Exp -> [Val] -> Val
-chainFun env f1 f2 (v1:v2:vs)
-    | VBool False <- applyFun env f1 [v1, v2]
-    = VBool False
-    | otherwise
-    = applyFun env f2 (v2:vs)
-
-apply :: Env -> VSub -> [Exp] -> ((Env -> Env), Exp)
-apply env@Env{ cls = cls } Sub{ subParams = prms, subFun = fun } exps
-    = retVal $ juncApply eval args
-    where
-    eval = applyFun env fun
-    args = map expToVal (prms `zip` exps)
-    expToVal (cxt, exp) = (evaluate env{ cxt = cxt } exp, isaType cls cxt "Bool")
+    (fenv, exp) = reduce (env `addSym` formal) body
+    formal = filter (not . null . fst) $ map argNameValue bound
+    argNameValue (ApplyArg name val _) = (name, val)
+
+apply :: Env -> VSub -> [Exp] -> [Exp] -> ((Env -> Env), Exp)
+apply env@Env{ cls = cls } Sub{ subParams = prms, subFun = fun } invs args =
+    case bindParams prms invs args of
+        Left errMsg     -> retVal $ VError errMsg (Val VUndef)
+        Right bindings  -> retVal $ juncApply eval (reverse . fst $ foldl doBind ([],env) bindings)
+    where
+    eval bound = applyFun env bound fun
+    doBind :: ([ApplyArg], Env) -> (Param, Exp) -> ([ApplyArg], Env)
+    doBind (bs, env) (prm@Param{ paramName = name, paramContext = cxt}, exp) =
+        let (val, coll) = expToVal env cxt exp in
+        (((ApplyArg name val coll): bs), env `addSym` [(name, val)])
+    expToVal env cxt exp = (evaluate env{ cxt = cxt } exp, isCollapsed cxt)
+    isCollapsed cxt
+        | isaType cls "Bool" cxt        = True
+        | isaType cls "Junction" cxt    = True
+        | otherwise                     = False
 
 juncApply f args
-    | (before, (VJunc j vs, cxt):after) <- break isTotalJunc args
-    = VJunc j [ juncApply f (before ++ ((v, cxt):after)) | v <- vs ]
-    | (before, (VJunc j vs, cxt):after) <- break isPartialJunc args
-    = VJunc j [ juncApply f (before ++ ((v, cxt):after)) | v <- vs ]
-    | (val, _):_ <- [ err | err@(VError _ _, _) <- args ]
+    | (before, (ApplyArg name (VJunc j vs) coll):after) <- break isTotalJunc args
+    = VJunc j [ juncApply f (before ++ ((ApplyArg name v coll):after)) | v <- vs ]
+    | (before, (ApplyArg name (VJunc j vs) coll):after) <- break isPartialJunc args
+    = VJunc j [ juncApply f (before ++ ((ApplyArg name v coll):after)) | v <- vs ]
+    | (val:_) <- [ val | (ApplyArg _ val@(VError _ _) _) <- args ]
     = val
     | otherwise
-    = f $ map fst args 
+    = f args
+
+isTotalJunc (ApplyArg _ (VJunc JAll _) b)   = not b
+isTotalJunc (ApplyArg _ (VJunc JNone _) b)  = not b
+isTotalJunc _                   = False
+
+isPartialJunc (ApplyArg _ (VJunc JOne _) b) = not b
+isPartialJunc (ApplyArg _ (VJunc JAny _) b) = not b
+isPartialJunc _                 = False
+
+toGlobal name
+    | (sigil, identifier) <- break (\x -> isAlpha x || x == '_') name
+    , last sigil /= '*'
+    = sigil ++ ('*':identifier)
+    | otherwise = name
 
 retVal :: Val -> ((Env -> Env), Exp)
 retVal val = (id, Val val)
+
+isGlobalExp (Syn name _) = name `elem` map ("&infix:" ++) (words ":= ::=")
+isGlobalExp _ = False
 
 reduce :: Env -> Exp -> ((Env -> Env), Exp)
@@ -99 +138 @@
     | Just val <- lookup var sym
     = retVal val
+    | Just val <- lookup (toGlobal var) sym
+    = retVal val
     | otherwise
     = retVal $ VError ("Undefined variable " ++ var) exp
@@ -105 +146 @@
     | name `isInfix` ";"
     , [left, right]     <- exps
-    , (env', exp)       <- runStatement "Any" (env, Val VUndef) left
-    , (env', exp)       <- runStatement cxt   (env', exp)       right
+    , (lead, final)     <- buildStatements exps
+    , (env', exp)       <- foldl (runStatement "Any") (env, Val VUndef) lead
+    , (env', exp)       <- runStatement cxt (env', exp) final
     = (const env', exp)
     | name `isInfix` ":="
@@ -115 +157 @@
     , [Var var _, Val val]  <- exps
     = (combineEnv id var val, Val VUndef)
-    where
+    | name `isInfix` "=>"
+    , [keyExp, valExp]  <- exps
+    , key               <- evaluate env keyExp
+    , val               <- evaluate env valExp
+    = retVal $ VPair key val
+    | name `isInfix` ","
+    = retVal $ VList $ concatMap (vCast . evaluate env{ cxt = "List" }) exps
+    | name `isInfix` "[]"
+    , [listExp, rangeExp]   <- exps
+    , list      <- evaluate env{ cxt = "List" } listExp
+    , range     <- evaluate env{ cxt = "List" } rangeExp
+    , slice     <- unfoldr (doSlice $ vCast list) (map vCast $ vCast range)
+    = retVal $ VList slice
+    where
+    doSlice :: [Val] -> [VInt] -> Maybe (Val, [VInt])
+    doSlice vs [] = Nothing
+    doSlice vs (n:ns)
+        | genericLength vs > n  = Just ((vs `genericIndex` n), ns)
+        | otherwise             = Nothing
+    buildStatements exps
+        | ((Syn name' exps'):rest)  <- exps
+        , name' `isInfix` ";"
+        = buildStatements (exps' ++ rest)
+        | (global, local)   <- partition isGlobalExp exps
+        , stmts             <- global ++ local
+        = (init stmts, last stmts)
     runStatement :: Cxt -> (Env, Exp) -> Exp -> (Env, Exp)
     runStatement cxt (env, (Val val)) exp
@@ -127 +194 @@
     isInfix name s = name == "&infix:" ++ s
 
-reduce env@Env{ cxt = cxt, cls = cls } exp@(App name exps)
+reduce env@Env{ cxt = cxt, cls = cls } exp@(App name invs args)
     | Just sub <- findSub name
-    = applySub sub exps
-    | otherwise
-    = retVal $ VError ("Undefined subroutine " ++ name ++ (show $ sym env)) exp
-    where
-    applySub sub exps
+    = applySub sub invs args
+    | otherwise
+    = retVal $ VError ("No compatible subroutine found: " ++ name) exp
+    where
+    applySub sub invs args
         -- list-associativity
-        | Sub{ subAssoc = "list" }  <- sub
-        , (App name' exps'):rest    <- exps
+        | Sub{ subAssoc = "list" }      <- sub
+        , (App name' invs' args'):rest  <- args
         , name == name'
-        = applySub sub (exps' ++ rest)
+        , null invs'
+        = applySub sub [] (args' ++ rest)
         -- fix subParams to agree with number of actual arguments
         | Sub{ subAssoc = "list", subParams = (p:_) }   <- sub
-        , trace ("meow " ++ (show exps)) True
-        = apply env sub{ subParams = (length exps) `replicate` p } exps
+        , null invs
+        = apply env sub{ subParams = (length args) `replicate` p } [] args
         -- chain-associativity
-        | Sub{ subAssoc = "chain", subFun = fun }   <- sub
-        , (App name' exps'):rest                    <- exps
+        | Sub{ subAssoc = "chain", subFun = fun, subParams = prm }   <- sub
+        , (App name' invs' args'):rest              <- args
         , Just sub'                                 <- findSub name'
-        , Sub{ subAssoc = "chain", subFun = fun' }  <- sub'
-        = applySub sub{ subFun = Prim $ chainFun env fun' fun } (exps' ++ rest)
+        , Sub{ subAssoc = "chain", subFun = fun', subParams = prm' } <- sub'
+        , null invs'
+        = applySub sub{ subFun = Prim $ chainFun env prm' fun' prm fun } [] (args' ++ rest)
         -- fix subParams to agree with number of actual arguments
         | Sub{ subAssoc = "chain", subParams = (p:_) }   <- sub
-        = apply env sub{ subParams = (length exps) `replicate` p } exps -- XXX Wrong
-        -- apply normally
-        | Sub{ subParams = [('*':p)] }              <- sub -- XXX Wrong
-        = apply env sub{ subParams = (length exps) `replicate` p } exps
+        , null invs
+        = apply env sub{ subParams = (length args) `replicate` p } [] args -- XXX Wrong
+        -- normal application
         | otherwise
-        = apply env sub exps
+        = apply env sub invs args
     findSub name
         | ((_, sub):_) <- sort (subs name)  = Just sub
         | otherwise                         = Nothing
-    subs name = [ ((subT, deltaFromCxt ret : map deltaFromScalar prms), sub)
-           | (n, val) <- sym env
-           , let sub@(Sub{ subType = subT, subReturns = ret, subParams = prms }) = vCast val
-           , n == name
-           , arityMatch sub prms exps
-           , deltaFromCxt ret /= 0
-           ]
-    deltaFromCxt        = deltaType cls cxt
-    deltaFromScalar x   = deltaType cls x "Scalar"
-    arityMatch Sub{ subAssoc = assoc, subParams = prms } x y
-        | assoc == "list"           = True
-        | Just _ <- find ((== '*') . head) prms
-        , assoc == "pre"            = True
-        | (length x) == (length y)  = True  -- XXX - slurping star
-        | otherwise                 = False
+    subs name = [
+        ( (isGlobal, subT, isMulti sub, bound, distance, order)
+        , fromJust fun
+        )
+        | ((n, val), order) <- sym env `zip` [0..]
+        , let sub@(Sub{ subType = subT, subReturns = ret, subParams = prms }) = vCast val
+        , n == name || n == toGlobal name
+        , let isGlobal = '*' `elem` n
+        , let fun = arityMatch sub (invs ++ args) -- XXX Wrong
+        , isJust fun
+        , deltaFromCxt ret /= 0
+        , let invocants = filter isInvocant prms
+        , let prms' = if null invocants then prms else invocants
+        , let distance = (deltaFromCxt ret : map (deltaFromScalar . paramContext) prms')
+        , let bound = either (const False) (const True) $ bindParams prms invs args
+        ]
+    deltaFromCxt            = deltaType cls cxt
+    deltaFromScalar ('*':x) = deltaFromScalar x
+    deltaFromScalar x       = deltaType cls x "Scalar"
 
 reduce env (Parens exp) = reduce env exp
 reduce env other = (id, other)
 
+arityMatch sub@Sub{ subAssoc = assoc, subParams = prms } args
+    | assoc == "list"               = Just sub
+    | isJust $ find isSlurpy prms
+    , assoc == "pre"                = Just sub
+--  | (length prms == length args)  = Just sub -- XXX optionals
+--  | (length prms >= length args)  = Just sub
+    | otherwise                     = Just sub
+    | otherwise                     = Nothing

src/Internals.hs

@@ -17 +17 @@
     module System.Environment,
     module System.IO,
+    module Control.Monad.Error,
     module Data.Bits,
     module Data.List,
+    module Data.Either,
     module Data.Word,
     module Data.Ratio,
@@ -34 +36 @@
 import System.Environment
 import System.IO hiding (try)
+import Control.Monad.Error
 import qualified System.IO (try)
 import Data.Bits
 import Data.Maybe
+import Data.Either
 import Data.List
 import Data.Ratio

src/Lexer.hs

@@ -19 +19 @@
           , P.commentLine    = "#"
           , P.nestedComments = False
-          , P.identStart     = letter <|> char '_'
-          , P.identLetter    = alphaNum <|> oneOf "_"
+          , P.identStart     = wordAlpha
+          , P.identLetter    = wordAny
           , P.reservedNames  = words $
                 "if then else do while skip"
@@ -39 +39 @@
           }
 
+wordAlpha   = satisfy (\x -> (isAlpha x || x == '_')) <?> "alphabetic word character"
+wordAny     = satisfy (\x -> (isAlphaNum x || x == '_')) <?> "word character"
+
 perl6Lexer = P.makeTokenParser perl6Def
 reservedOp = P.reservedOp perl6Lexer
@@ -49 +52 @@
 braces     = P.braces perl6Lexer
 brackets   = P.brackets perl6Lexer
+symbol     = P.symbol perl6Lexer
 stringLiteral = choice
     [ P.stringLiteral  perl6Lexer

src/Parser.hs

@@ -17 +17 @@
 type StateParser a = GenParser Char () a
 
-operators :: OperatorTable Char () Exp
-operators =
+tightOperators =
     [ methOps  " . .+ .? .* .+ .() .[] .{} .<<>> .= "   -- Method postfix
     , postOps  " ++ -- "                                -- Auto-Increment
@@ -37 +36 @@
     , leftOps  " || ^^ // "                             -- Tight Or
     , ternOps  [("??", "::")]                           -- Ternary
-    , rightSyn " = := ::= += **= xx= "                  -- Assignment
-    , listOps  " , "                                    -- List Item Separator
-    , preOps   primitiveListFunctions                   -- List Operator
+    , leftSyn  " = := ::= += **= xx= "                  -- Assignment
+    ]
+
+looseOperators =
+    [ preOps   primitiveListFunctions                   -- List Operator
     , leftOps  " ==> "                                  -- Pipe Forward
     , leftOps  " and "                                  -- Loose And
     , leftOps  " or xor err "                           -- Loose Or
-    , leftSyn  " ; "                                    -- Terminator
-    ]
+    ]
+
+operators :: OperatorTable Char () Exp
+operators = concat $
+    [ tightOperators
+    , [ listOps  " , " ]                                -- Comma
+    , looseOperators
+    , [ listSyn  " ; " ]                                -- Terminator
+    ]
+
+litOperators = tightOperators ++ looseOperators
 
 primitiveListFunctions = " not <== any all one none"
@@ -51 +61 @@
 
 parseOp = buildExpressionParser operators parseTerm
+parseLitOp = buildExpressionParser litOperators parseLitTerm
 
 ops f s = [f n | n <- words s]
 
-preOps      = ops $ makeOp1 Prefix "&prefix:" App
-postOps     = ops $ makeOp1 Postfix "&postfix:" App
-leftOps     = ops $ makeOp2 AssocLeft "&infix:" App
-rightOps    = ops $ makeOp2 AssocRight "&infix:" App
-noneOps     = ops $ makeOp2 AssocNone "&infix:" App
+doApp str args = App str [] args
+
+preOps      = ops $ makeOp1 Prefix "&prefix:" doApp
+postOps     = ops $ makeOp1 Postfix "&postfix:" doApp
+leftOps     = ops $ makeOp2 AssocLeft "&infix:" doApp
+rightOps    = ops $ makeOp2 AssocRight "&infix:" doApp
+noneOps     = ops $ makeOp2 AssocNone "&infix:" doApp
 listOps     = leftOps
 chainOps    = leftOps
 leftSyn     = ops $ makeOp2 AssocLeft "&infix:" Syn
 rightSyn    = ops $ makeOp2 AssocRight "&infix:" Syn
+listSyn     = leftSyn
+chainSyn    = leftSyn
 
 -- chainOps    = ops $ makeOpChained
@@ -74 +89 @@
     return $ \x y -> con (sigil ++ name) [x,y]
 
-parseTerm = parseDecl
-    <|> parseVar
-    <|> parseLit
-    <|> do
-        cs <- parens parseOp
-        return $ Parens cs
-    <|> parseApply
-{-
-    <|> do
-        cs <- parseOp
-        return cs
--}
---  <|> nonTerm
+parseParens parse = do
+    cs <- parens parse
+    return $ Parens cs
+
+parseTerm = choice
+    [ parseDecl
+    , parseVar
+    , parseLit
+    , parseApply
+    , parseParens parseOp
+    ]
     <?> "term"
 
-buildSub body = VSub $ Sub
-    { subType       = SubRoutine
-    , subAssoc      = "pre"
-    , subParams     = ["*List"]
-    , subReturns    = "Any"
-    , subFun        = body
+parseLitTerm = choice
+    [ parseVar
+    , parseLit
+    , parseApply
+    , parseParens parseLitOp
+    ]
+    <?> "argument"
+
+parseTrait trait = do
+    symbol "is"
+    symbol trait
+    identifier
+
+parseBareTrait trait = do
+    choice [ parseTrait trait
+           , do { symbol trait ; identifier }
+           ]
+
+parseContext = do
+    lead    <- upper
+    rest    <- many1 wordAny
+    return (lead:rest)
+
+parseParamDefault True  = return $ Val VUndef
+parseParamDefault False = option (Val VUndef) $ do
+    symbol "="
+    parseLitOp
+
+parseFormalParam = do
+    cxt     <- option "" $ parseContext
+    sigil   <- option "" $ choice . map string $ words " ? * + ++ "
+    name    <- parseVarName
+    let required = (sigil /=) `all` ["?", "+"]
+    exp     <- parseParamDefault required
+    return $ buildParam cxt sigil name exp
+
+parseApply = lexeme $ do
+    name            <- identifier
+    (invs:args:_)   <- parseParamList parseLitTerm
+    return $ App ('&':name) invs args
+
+parseParamList parse = do
+    formal <- maybeParens ((parse `sepBy` symbol ",") `sepBy` symbol ":")
+    case formal of
+        []                  -> return [[], []]
+        [args]              -> return [[], args]
+        [invocants,args]    -> return formal
+        _                   -> fail "Only one invocant list allowed"
+
+parseFormalParameters = do
+    (invs:args:_) <- parseParamList parseFormalParam
+    return $ (map (\e -> e { isInvocant = True }) invs) ++ args
+
+nameToParam :: String -> Param
+nameToParam name = Param
+    { isInvocant    = False
+    , isSlurpy      = (name == "$_")
+    , isOptional    = False
+    , isNamed       = False
+    , paramName     = name
+    , paramContext  = (if name == "$_" then "List" else "Scalar")
+    , paramDefault  = Val VUndef
     }
 
 parseDecl = lexeme $ do
-    lexeme (string "sub")
+    multi   <- option False $ do { symbol "multi" ; return True }
+    symbol "sub"
     pos     <- getPosition
     name    <- identifier
+    cxt     <- option "Any" $ parseBareTrait "returns"
+    formal  <- option Nothing $ return . Just =<< parens parseFormalParameters
     body    <- braces parseOp
-    return $ Syn "&infix:::=" [Var ('&':name) pos, Val (buildSub body)]
+    let (fun, names) = extract (body,[])
+        params = (maybe [] id formal) ++ map nameToParam names
+    -- Check for placeholder vs formal parameters
+    unless (isNothing formal || null names || names == ["$_"] ) $
+        fail "Cannot mix placeholder variables with formal parameters"
+    let sub = Sub { isMulti       = multi
+                  , subType       = SubRoutine
+                  , subAssoc      = "pre"
+                  , subReturns    = cxt
+                  , subParams     = if null params then [defaultArrayParam] else params
+                  , subFun        = fun
+                  }
+    return $ Syn "&infix:::=" [Var ('&':name) pos, Val (VSub sub)]
 
 maybeParens p = choice [ parens p, p ]
 
-parseApply = lexeme $ do
-    name    <- identifier
-    args    <- maybeParens $ parseTerm `sepBy` (lexeme $ char ',')
-    return $ App ('&':name) args
-
-parseVar = lexeme $ do
+parseVarName = lexeme $ do
+    sigil   <- oneOf "$@%&"
+    caret   <- option "" $ choice [ string "^", string "*" ]
+    name    <- many1 wordAny
+    return $ (sigil:caret) ++ name
+
+parseVar = do
     pos     <- getPosition
-    sigil   <- oneOf "$@%&"