Changeset 3053

Show
Ignore:
Timestamp:
05/12/05 11:58:41 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
4536
Message:

* Set.pm now passes all its tests.

Files:
7 modified

Legend:

Unmodified
Added
Removed

  • ext/Set/lib/Set.pm

    r3048 r3053  
    44class Set; 
    55 
    6 sub set(*@contents) is export returns Set { 
    7     return Set.new(*@contents); 
    8 }; 
     6sub set (*@contents) returns Set is export { 
     7    my $set = Set.new; 
     8    $set.insert(@contents); 
     9    return $set; 
     10} 
    911 
    1012# the Set is represented as a hash of (v => v) 
    1113has Hash %:members; 
    1214 
    13 sub new($self: *@items) { 
    14     $self.insert(@items); 
    15 }; 
     15method members() returns List { 
     16    %:members.values; 
     17} 
    1618 
    17 sub members($self:) returns List { 
    18     %:members.values; 
    19 }; 
    20  
    21 sub insert($self: *@items) returns int { 
    22     my int $inserted = 0; 
     19method insert(*@items) returns Int { 
     20    my Int $inserted = 0; 
    2321    for @items -> $item { 
    24         if ( !%:members.exists($item) ) { 
     22        unless ( %:members.exists($item) ) { 
    2523            $inserted++; 
    26             %:members<$item> = $item; 
     24            %:members{$item} = $item; 
    2725        } 
    2826    } 
    2927    return $inserted; 
    30 }; 
     28} 
    3129 
    32 sub remove($self: *@items) returns int { 
    33     my int $removed = 0; 
     30method remove(*@items) returns Int { 
     31    my Int $removed = 0; 
    3432    for @items -> $item { 
    3533        if ( %:members.delete($item) ) { 
    … …  
    3836    } 
    3937    return $removed; 
    40 }; 
     38} 
    4139 
    42 sub includes($self: *@items) returns Bool { 
     40method includes(*@items) returns Bool { 
    4341    return %:members.exists(all(@items)); 
    44 }; 
     42} 
    4543 
    46 sub member($self: $item) returns Object { 
    47     return %:members<$item>; 
    48 }; 
     44method member($item) returns Object { 
     45    return %:members{$item} 
     46} 
    4947 
    50 sub size($self:) returns int { 
    51     %:members.size; 
    52 }; 
     48method size() returns int { 
     49    +%:members.keys; 
     50} 
    5351 
    54 sub invert($self: *@items) returns int { 
     52method invert(*@items) returns int { 
    5553    my int $rv; 
    5654    for @items -> $item { 
    … …  
    6361    } 
    6462    return $rv; 
    65 }; 
     63} 
    6664 
    67 sub clear($self:) { 
    68     %:members=(); 
    69 }; 
     65method clear() { 
     66    undef %:members; 
     67} 
    7068 
    71 &element  ::= &member; 
    72 &has      ::= &includes; 
    73 &contains ::= &includes; 
    74 &count    ::= &size; 
    75 &delete   ::= &remove; 
    76  
    77  
     69our &Set::count ::= &Set::size; 
     70our &Set::has   ::= &Set::includes; 

  • ext/Set/t/basic.t

    r3047 r3053  
    77use Set; 
    88 
    9 my $bob = bless {}, "Bob"; 
    10 my $bert = bless {}, "Bert"; 
     9class Bob {}; 
     10class Bert {}; 
     11 
     12my $bob = Bob.new; 
     13my $bert = Bert.new; 
    1114 
    1215my $set = set(0, 1, 2, 3, $bob); 
    13 isa_ok($set, "Set", "set()"); 
     16is($set.ref, ::Set, "set()"); 
    1417 
    1518ok($set.includes(0), ".includes(0)"); 
    … …  
    3134is($set.size, 6, ".size"); 
    3235# remove also returns the number of elements removed 
    33 is($set.remove(4, 5), 1, ".remove"); 
     36is($set.remove(4, 5), 2, ".remove"); 
    3437 
    3538# members returns all the items.  testing this with junctions is maybe 
    3639# not thorough enough... 
    37 ok(all($set.members) == one(0, 1, 2, 3, $bob), ".members()"); 
     40is($set.members, [0, 1, 2, 3, $bob], ".members()"); 
    3841 
    3942$set.clear(); 
    … …  
    4952# sub-class test, too - to make sure the interface works if you only 
    5053# define the bare minimum number of methods in a Set sub-class 
     54 

  • src/Pugs/AST/Internals.hs

    r3034 r3053  
    7575             -> (Eval a) -- ^ The @else@ case 
    7676             -> Eval a 
     77ifValTypeIsa v (':':typ) trueM falseM = ifValTypeIsa v typ trueM falseM 
    7778ifValTypeIsa v typ trueM falseM = do 
    7879    env <- ask 
    … …  
    339340    vCast (VHandle h)   = "<" ++ "VHandle (" ++ (show h) ++ ">" 
    340341    vCast (VMatch m)    = matchStr m 
    341     vCast (VType typ)   = "::" ++ showType typ 
     342    vCast (VType typ)   = showType typ -- "::" ++ showType typ 
    342343    vCast (VObject o)   = "<obj:" ++ showType (objType o) ++ ">" 
    343344    vCast x             = castFail x 

  • src/Pugs/Eval.hs

    r3033 r3053  
    823823chainFun :: Params -> Exp -> Params -> Exp -> [Val] -> Eval Val 
    824824chainFun p1 f1 p2 f2 (v1:v2:vs) = do 
    825     val <- applyExp (chainArgs p1 [v1, v2]) f1 
     825    val <- applyExp SubPrim (chainArgs p1 [v1, v2]) f1 
    826826    case val of 
    827827        VBool False -> return val 
    828         _           -> applyExp (chainArgs p2 (v2:vs)) f2 
     828        _           -> applyExp SubPrim (chainArgs p2 (v2:vs)) f2 
    829829    where 
    830830    chainArgs prms vals = map chainArg (prms `zip` vals) 
    … …  
    832832chainFun _ _ _ _ _ = internalError "chainFun: Not enough parameters in Val list" 
    833833 
    834 applyExp :: [ApplyArg] -> Exp -> Eval Val 
    835 applyExp bound (Prim f) = 
     834applyExp :: SubType -> [ApplyArg] -> Exp -> Eval Val 
     835applyExp _ bound (Prim f) = 
    836836    f [ argValue arg | arg <- bound, (argName arg !! 1) /= '_' ] 
    837 applyExp [] body = evalExp body 
    838 applyExp bound@(arg:_) body = do 
     837applyExp _ [] body = evalExp body 
     838applyExp styp bound@(arg:_) body = do 
    839839    -- introduce $?SELF and $_ as the first invocant. 
    840     inv <- invocant 
     840    inv <- if styp <= SubMethod then invocant else return [] 
    841841    pad <- formal 
    842842    enterLex (inv ++ pad) $ evalExp body 
    … …  
    882882                    (`juncApply` bound) $ \realBound -> do 
    883883                        enterSub sub $ do 
    884                             applyExp realBound fun 
     884                            applyExp (subType sub) realBound fun 
    885885                retVal val 
    886886    where 

  • src/Pugs/Parser.hs

    r3027 r3053  
    3333ruleProgram :: RuleParser Env 
    3434ruleProgram = rule "program" $ do 
     35    env <- getState 
    3536    statements <- ruleBlockBody 
    3637    -- error $ show statements 
    3738    eof 
    38     env <- getState 
    39     return $ env { envBody = mergeStmts emptyExp statements, envStash = "" } 
     39    env' <- getState 
     40    return $ env' 
     41        { envBody       = mergeStmts emptyExp statements 
     42        , envStash      = "" 
     43        , envPackage    = envPackage env 
     44        } 
    4045 
    4146ruleBlock :: RuleParser Exp 
    … …  
    310315            , subName       = name' 
    311316            , subPad        = envLexical env 
    312             , subType       = SubRoutine 
     317            , subType       = if isMethod then SubMethod else SubRoutine 
    313318            , subAssoc      = "pre" 
    314319            , subReturns    = mkType typ'' 
    … …  
    501506ruleModuleDeclaration :: RuleParser Exp 
    502507ruleModuleDeclaration = rule "module declaration" $ do 
    503     symbol "module" <|> symbol "class" 
    504     n <- ruleQualifiedIdentifier 
    505     v <- option "" $ ruleVersionPart 
    506     a <- option "" $ ruleAuthorPart 
    507     return $ Syn "module" [Val . VStr $ n ++ v ++ a] -- XXX 
     508    symbol "package" <|> symbol "module" <|> symbol "class" 
     509    name    <- ruleQualifiedIdentifier 
     510    v       <- option "" $ ruleVersionPart 
     511    a       <- option "" $ ruleAuthorPart 
     512    env     <- getState 
     513    let exp = Syn ":=" [Var (':':name), Syn "\\{}" [Syn "," []]] 
     514    unsafeEvalExp (Sym SGlobal (':':name) exp) 
     515    setState env{ envPackage = name, envClasses = envClasses env `addNode` mkType name } 
     516    return $ Syn "module" [Val . VStr $ name ++ v ++ a] -- XXX 
    508517 
    509518ruleVersionPart = do -- version - XXX 
    … …  
    980989        , ruleLit 
    981990        , ruleClosureTrait True 
     991        , ruleTypeVar 
    982992        , ruleTypeLiteral 
    983993        , parseApply 
    … …  
    987997    return $ combine (reverse fs) term 
    988998 
     999ruleTypeVar :: RuleParser Exp 
     1000ruleTypeVar = rule "type" $ try $ do 
     1001    string "::" 
     1002    name <- ruleQualifiedIdentifier 
     1003    return . Val . VType $ mkType name 
     1004 
    9891005ruleTypeLiteral :: RuleParser Exp 
    9901006ruleTypeLiteral = rule "type" $ do 
    9911007    env     <- getState 
    992     optional $ string "::" 
    9931008    name    <- tryChoice [ 
    9941009        do { symbol n; notFollowedBy (alphaNum <|> char ':'); return n } 
    … …  
    11961211makeVar ('$':'<':name) = Syn "{}" [Var "$/", doSplitStr (tail name)] 
    11971212makeVar (sigil:'.':name) = 
     1213    Cxt (cxtOfSigil sigil) (Syn "{}" [Var "$?SELF", Val (VStr name)]) 
     1214makeVar (sigil:':':name) = 
    11981215    Cxt (cxtOfSigil sigil) (Syn "{}" [Var "$?SELF", Val (VStr name)]) 
    11991216makeVar var = Var var 

  • src/Pugs/Prim.hs

    r3042 r3053  
    4646op0 "|"  = fmap opJuncAny  . mapM fromVal 
    4747op0 "want"  = const $ fmap VStr (asks envWant) 
     48op0 "bool::true" = const $ return (VBool True) 
     49op0 "bool::false" = const $ return (VBool False) 
    4850op0 "time"  = const $ do 
    4951    clkt <- liftIO getClockTime 
    … …  
    431433    handleOf (VList [x]) = handleOf x 
    432434    handleOf v = fromVal v 
    433 op1 "ref"   = fmap (VStr . showType) . evalValType 
     435op1 "ref"   = fmap VType . evalValType 
    434436op1 "pop"   = \x -> join $ doArray x array_pop -- monadic join 
    435437op1 "shift" = \x -> join $ doArray x array_shift -- monadic join 
    … …  
    12071209\\n   List      pre     Pugs::Internals::runInteractiveCommand    (?Str=$_)\ 
    12081210\\n   List      pre     Pugs::Internals::openFile    (?Str,?Str=$_)\ 
     1211\\n   Bool      pre     bool::true ()\ 
     1212\\n   Bool      pre     bool::false ()\ 
    12091213\\n" 

  • src/Pugs/Prim/Keyed.hs

    r2961 r3053  
    9595existsFromRef (MkRef (IScalar sv)) val = do 
    9696    refVal  <- scalar_fetch sv 
    97     ref     <- fromVal refVal 
    98     existsFromRef ref val 
     97    case refVal of 
     98        VRef ref    -> existsFromRef ref val 
     99        VList _     -> (`existsFromRef` val) =<< fromVal refVal 
     100        _           -> return False 
    99101existsFromRef ref _ = retError "Not a keyed reference" ref 
    100102 
    … …  
    116118deleteFromRef (MkRef (IScalar sv)) val = do 
    117119    refVal  <- scalar_fetch sv 
    118     ref     <- fromVal refVal 
    119     deleteFromRef ref val 
     120    case refVal of 
     121        VRef ref    -> deleteFromRef ref val 
     122        VList _     -> (`deleteFromRef` val) =<< fromVal refVal 
     123        _           -> return undef 
    120124deleteFromRef ref _ = retError "Not a keyed reference" ref