Changeset 14534 for src/Pugs/Prim.hs

Timestamp:

10/27/06 02:36:49 (2 years ago)

Author:

audreyt

Message:

* Pugs.Prim: Attribute initializers now carries through to derived classes:

class C { has $.x = 9 };
class D is C;
D.new.x; # 9

Same applies for "does".

Files:

• src/Pugs/Prim.hs (modified) (4 diffs)

src/Pugs/Prim.hs

@@ -1258 +1258 @@
     fetch   <- doHash meta hash_fetchVal
 
+    attrs   <- fetch "attrs"
+
     name    <- fromVal =<< fetch "name" :: Eval String
     roles   <- fromVals =<< fetch "does" :: Eval [String]
+    supers  <- fromVals =<< fetch "is" :: Eval [String]
 
     -- Role flattening -- copy over things there and put it to symbol table
@@ -1266 +1269 @@
     -- XXX - also, copy over the inheritance chain from role's metaobject
     mixinRoles name roles
+
+    -- Merge in slot definitions in "attrs"
+    defs        <- join $ doHash attrs hash_fetch
+    parentAttrs <- forM (roles ++ supers) $ fetchMetaInfo "attrs"
+    store       <- doHash attrs hash_store
+    store $ Map.unions (defs:parentAttrs)
+    
     return cls
 
@@ -1273 +1283 @@
     named   <- fromVal n
 
-    meta    <- readRef =<< fromVal =<< evalExp (_Var (':':'*':showType typ))
-    fetch   <- doHash meta hash_fetchVal
-    defs    <- fromVal =<< fetch "attrs"
-
+    defs    <- fetchMetaInfo "attrs" (showType typ)
     attrs   <- liftIO $ H.new (==) H.hashString
     writeIVar (IHash attrs) (named `Map.union` defs)
@@ -1369 +1376 @@
     split' [] xs n = VList $ (map (VStr . (:[])) (take (n-1) xs)) ++ [ VStr $ drop (n-1) xs ]
     split' glue xs n = VList $ map VStr $ split_n glue xs n
+
+-- XXX - The "String" below wants to be Type.
+fetchMetaInfo :: Value a => String -> [Char] -> Eval a
+fetchMetaInfo key typ = do
+    meta    <- readRef =<< fromVal =<< evalExp (_Var (':':'*':typ))
+    fetch   <- doHash meta hash_fetchVal
+    fromVal =<< fetch key
 
 -- |Implementation of 4-arity primitive operators and functions.