Changeset 16339

Timestamp:

05/17/07 23:16:21 (18 months ago)

Author:

audreyt

Message:

* Things actually run now, yay. Next step is to convert

Params over to the new convention...

Location:

src/Pugs

Files:

• AST/Internals/Instances.hs (modified) (1 diff)
• AST/Pad.hs (modified) (2 diffs)
• Eval.hs (modified) (4 diffs)
• Eval/Var.hs (modified) (1 diff)
• Monads.hs (modified) (2 diffs)
• Parser.hs (modified) (1 diff)
• Parser/Program.hs (modified) (1 diff)
• Parser/Util.hs (modified) (1 diff)
• Pretty.hs (modified) (1 diff)
• Types.hs (modified) (1 diff)

src/Pugs/AST/Internals/Instances.hs

@@ -610 +610 @@
     asYAML (NonTerm aa) = asYAMLseq "NonTerm" [asYAML aa]
 
-instance YAML LexPads where
+instance YAML LexPad where
     fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
         "PRuntime" -> do

src/Pugs/AST/Pad.hs

@@ -2 +2 @@
 module Pugs.AST.Pad (
   mkPad, diffPads, unionPads, padKeys, filterPad, adjustPad, mergePadEntry, emptyPad,
-  mergeMPads, readMPad, writeMPad, appendMPad
+  mergeLexPads, readMPad, writeMPad, appendMPad
 ) where
 import Pugs.Internals
@@ -32 +32 @@
 
 {-|
-Merge multiple mutable pads into one.
+Merge multiple (possibly mutable) pads into one.
 -}
-mergeMPads :: MonadSTM m => [MPad] -> m Pad
-mergeMPads chain = stm $ do
-    pads <- mapM readTVar chain
+mergeLexPads :: MonadSTM m => LexPads -> m Pad
+mergeLexPads chain = stm $ do
+    pads <- forM chain $ \lpad -> case lpad of
+        PRuntime p      -> return p
+        PCompiling p    -> readTVar p
     return . MkPad $ Map.unionsWith mergePadEntry (map padEntries pads)
 

src/Pugs/Eval.hs

@@ -67 +67 @@
         { envContext = CxtVoid
         , envLexical = emptyPad
-        , envLexPads = PCompiling []
+        , envLexPads = []
         , envCaller  = Nothing
         , envCompPad = Nothing
@@ -291 +291 @@
                 | otherwise -> do
                     s <- isStrict
-                    if s then do die "Undeclared variable" var
-                         else do lv <- asks envLValue
-                                 if lv then evalExp (Sym SOur var mempty Noop (Var var)) else retEmpty
+                    if s then do 
+                            lex     <- asks envLexical
+                            pads    <- asks envLexPads
+                            die "Undeclared variable" (var, lex, pads)
+                         else do
+                            lv <- asks envLValue
+                            if lv then evalExp (Sym SOur var mempty Noop (Var var)) else retEmpty
 
 _scalarContext :: Cxt
@@ -472 +476 @@
     -- add &?BLOCK &?ROUTINE etc here
     started <- if isCompileTime env then return Nothing else fmap Just (stm $ newTVar False)
+    pad     <- fmap (`mappend` subInnerPad sub) $ mergeLexPads (envLexPads env)
     return $ VCode sub
-        { subCont      = cont
-        , subOuterPads = envLexPads env
-        , subStarted   = started
+        { subCont       = cont
+        , subOuterPads  = envLexPads env
+        , subLexical    = pad
+        , subStarted    = started
         }
     where
@@ -1332 +1338 @@
             value = argValue arg
         evalExp $ Syn "=" [Syn "{}" [Val invocant, Val (VStr name)], Val value]
+    -- Otherwise we write back to the bindings.
     applyThunk styp normal $ MkThunk (evalExp body) anyType
     where

src/Pugs/Eval/Var.hs

@@ -68 +68 @@
         mpads <- asks envLexPads
         case mpads of
-            PCompiling (_:outers@(outer:_))  -> local (\env -> env{ envLexPads = PCompiling outers }) $ do
+            (_:outers@(outer:_))  -> local (\env -> env{ envLexPads = outers }) $ do
                 case dropVarPkg (__"OUTER") v of
                     Just v' -> outerLevel v'
                     _       -> do
-                        pad <- stm $ readTVar outer
+                        pad <- case outer of
+                            PRuntime p  -> return p
+                            PCompiling p-> stm $ readTVar p
                         return (lookupPad v pad)
-            PRuntime (_:outers@(outer:_))    -> local (\env -> env{ envLexPads = PRuntime outers }) $ do
-                case dropVarPkg (__"OUTER") v of
-                    Just v' -> outerLevel v'
-                    _       -> return (lookupPad v outer)
             _       -> die "cannot access OUTER:: in top level" name
 

src/Pugs/Monads.hs

@@ -268 +268 @@
             -- Entering a block.
             blockRec  <- genSym (cast "&?BLOCK") (codeRef (orig sub))
-            pad       <- readLexical sub
-            lexpads   <- case subOuterPads sub of
-                PRuntime ps     -> return $ PRuntime (subInnerPad sub : ps)
-                PCompiling ps   -> do
-                    pad'    <- stm $ newTVar (subInnerPad sub) -- XXX
-                    return (PCompiling (pad':ps))
+            pad       <- fmap (`mappend` subInnerPad sub) $ mergeLexPads (subOuterPads sub)
             return $ \e -> e
                 { envLexical = combine [blockRec] pad
                 , envPackage = subPackage sub
-                , envLexPads = lexpads
+                , envLexPads = (PRuntime (subInnerPad sub):subOuterPads sub)
                 }
         | otherwise = do
             subRec    <- genSym (cast "&?ROUTINE") (codeRef (orig sub))
             callerRec <- genSym (cast "&?CALLER_CONTINUATION") (codeRef $ ccSub cc env)
-            pad       <- readLexical sub
-            lexpads   <- case subOuterPads sub of
-                PRuntime ps     -> return $ PRuntime (subInnerPad sub : ps)
-                PCompiling ps   -> do
-                    pad'    <- stm $ newTVar (subInnerPad sub) -- XXX
-                    return (PCompiling (pad':ps))
+            pad       <- fmap (`mappend` subInnerPad sub) $ mergeLexPads (subOuterPads sub)
             return $ \e -> e
                 { envLexical = combine ([subRec, callerRec]) pad
                 , envPackage = subPackage sub
-                , envLexPads = lexpads
+                , envLexPads = (PRuntime (subInnerPad sub):subOuterPads sub)
                 }
     ccSub :: (Val -> Eval Val) -> Env -> VCode
@@ -299 +289 @@
         , subBody = Prim $ doCC cc
         }
-
-readLexical :: MonadSTM m => VCode -> m Pad
-readLexical sub = case subOuterPads sub of
-    PCompiling pads -> fmap (`mappend` subInnerPad sub) $ mergeMPads pads 
-    _               -> return (subLexical sub)
 
 makeParams :: Env -> [Param]

src/Pugs/Parser.hs

@@ -385 +385 @@
         unsafeEvalLexDiff (mkSym sub nameQualified Noop)
             `finallyM` clearDynParsers
+
+    -- XXX - Generate init pad for each of our params...
 
     block    <- ruleBlock

src/Pugs/Parser/Program.hs

@@ -174 +174 @@
     env' <- getRuleEnv
     return $ env'
-        { envBody       = App main Nothing []
+        { envBody       = App main Nothing [_Var "@*ARGS"]
         , envPackage    = envPackage env
         }

src/Pugs/Parser/Util.hs

@@ -50 +50 @@
             , envLexical = envLexical env
             , envLexPads = envLexPads env
+            , envCompPad = envCompPad env
             }
         , s_closureTraits = outerTraits

src/Pugs/Pretty.hs

@@ -179 +179 @@
     format (VRef x) = format x
     format (VList x) = format x
-    format (VCode x) = (<> braces (format $ subBody x)) . (<+> format (subLexical x)) . (<> format (subParams x)) . text $ case subType x of
+    format (VCode x) = (<> braces (format $ subBody x)) . (<+> format (subInnerPad x)) . (<> format (subParams x)) . text $ case subType x of
         SubMacro        -> "macro "
         SubRoutine      -> "sub "

src/Pugs/Types.hs

@@ -218 +218 @@
 
 instance Show Var where
-    show var = Buf.unpack (cast var)
+    show var = show (cast var :: ByteString)
 
 varToBuf :: Var -> ByteString