Changeset 2248 for src/Pugs/Bind.hs

Show
Ignore:
Timestamp:
04/23/05 19:36:55 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
3669
Message:

* thanks to juerd, we now check for extra slurpy arguments.

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Bind.hs

    r2221 r2248  
    3636 
    3737bindHash :: [Exp] -> [Param] -> MaybeError Bindings 
    38 bindHash _ []          = return [] 
     38bindHash _ []           = return [] 
    3939bindHash [] [p]         = return [ (p, emptyHashExp) ] 
    4040bindHash vs (p:ps@(_:_))= do 
    … …  
    4343bindHash vs [p]         = return [ (p, Syn "\\{}" vs) ] -- XXX cast to Hash 
    4444 
    45 bindArray :: [Exp] -> [Param] -> MaybeError Bindings 
    46 bindArray vs ps = do 
    47     case foldM (doBindArray (Syn "*" [Syn "," vs])) ([],0) prms of 
    48         Left errMsg     -> fail errMsg 
    49         Right (bound,_) -> return $ reverse bound 
     45bindArray :: [Exp] -> [Param] -> SlurpLimit -> MaybeError (Bindings, SlurpLimit) 
     46bindArray vs ps oldLimit = do 
     47    let exp = Syn "*" [Syn "," vs] 
     48    case foldM (doBindArray exp) ([], 0) prms of 
     49        Left errMsg      -> fail errMsg 
     50        Right (bound, n) -> do 
     51            let newLimit = case prms of 
     52                    ((_, '@'):_) -> oldLimit 
     53                    _            -> (n, exp) : oldLimit 
     54            return (reverse bound, newLimit) 
    5055    where 
    5156    prms = map (\p -> (p, (head (paramName p)))) ps  
    … …  
    130135bindSomeParams :: VCode -> [Exp] -> [Exp] -> MaybeError VCode 
    131136bindSomeParams sub invsExp argsExp = do 
    132     let params    = subParams sub 
    133         bindings  = subBindings sub 
     137    let params     = subParams sub 
     138        bindings   = subBindings sub 
     139        slurpLimit = subSlurpLimit sub 
    134140        (invPrms, argPrms) = span isInvocant params 
    135141        (givenInvs, givenArgs) = if null invPrms 
    … …  
    146152    -- Bind slurpy arrays and hashes 
    147153    let (slurpNamed, slurpPos) = partition (('%' ==) . head . paramName) slurpyPrms 
    148         defaultPos      = if hasDefaultArray  then [] else [defaultArrayParam] 
     154        -- defaultPos      = if hasDefaultArray  then [] else [defaultArrayParam] 
    149155        defaultNamed    = if hasDefaultHash   then [] else [defaultHashParam] 
    150156        defaultScalar   = if hasDefaultScalar then [] else [] -- XXX - fetch from *@_ 
    151         hasDefaultArray = isJust (find (("@_" ==) . paramName) slurpPos) 
    152                         || null slurpPos 
    153157        hasDefaultHash  = isJust (find (("%_" ==) . paramName) slurpNamed) 
    154158        hasDefaultScalar= isJust (find (("$_" ==) . paramName) params) 
    155159         
    156160    boundHash   <- bindHash namedForSlurp (slurpNamed ++ defaultNamed) -- put leftover named args in %_ 
    157     boundArray  <- bindArray posForSlurp (slurpPos ++ defaultPos) -- put leftover positional args in @_ 
     161    (boundArray, newSlurpLimit) <- bindArray posForSlurp slurpPos slurpLimit 
    158162    boundScalar <- return $ defaultScalar `zip` (givenInvs ++ givenArgs) -- put, uh, something in $_ 
    159163 
    … …  
    162166     
    163167    return sub 
    164         { subBindings = newBindings 
    165         , subParams   = newParams 
     168        { subBindings   = newBindings 
     169        , subParams     = newParams 
     170        , subSlurpLimit = newSlurpLimit 
    166171        } 
    167172