Changeset 21673

Show
Ignore:
Timestamp:
08/01/08 13:56:05 (5 months ago)
Author:
audreyt
Message:

* Import Pugs 6.2.13.11 from Hackage into our source tree.
* Highlights:

  • Much faster startup time
  • Slightly faster compilation time (mostly due to refactored Pugs.AST.Internals)
  • Portable-to-Win32 readline thanks to Haskeline
Location:
src
Files:
4 added
38 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs.hs

    r17058 r21673  
    124124 
    125125repLoop :: IO () 
    126 repLoop = do 
    127     initializeShell 
    128     tvEnv <- io . newTVarIO . noEnvDebug =<< tabulaRasa defaultProgramName 
     126repLoop = initializeShell $ do 
     127    tvEnv <- io . newTVarIO . noEnvDebug =<< io (tabulaRasa defaultProgramName) 
    129128    fix $ \loop -> do 
    130129        command <- getCommand 
    … …  
    135134                env <- fmap noEnvDebug (tabulaRasa defaultProgramName) 
    136135                stm (writeTVar tvEnv env) 
    137         case command of 
    138             CmdQuit           -> putStrLn "Leaving pugs." 
    139             CmdLoad fn        -> doLoad tvEnv fn >> loop 
    140             CmdRun opts prog  -> doRunSingle tvEnv opts prog >> loop 
    141             CmdParse prog     -> parseEnv pretty prog >> loop 
    142             CmdParseRaw prog  -> parseEnv show prog >> loop 
    143             CmdHelp           -> printInteractiveHelp >> loop 
    144             CmdReset          -> resetEnv >> loop 
     136        if command == CmdQuit then io $ putStrLn "Leaving pugs." else do 
     137            io $ case command of 
     138                CmdLoad fn        -> doLoad tvEnv fn 
     139                CmdRun opts prog  -> doRunSingle tvEnv opts prog 
     140                CmdParse prog     -> parseEnv pretty prog 
     141                CmdParseRaw prog  -> parseEnv show prog 
     142                CmdHelp           -> printInteractiveHelp 
     143                CmdReset          -> resetEnv 
     144                _                 -> return () 
     145            loop 
    145146 
    146147mainWith :: ([String] -> IO a) -> IO () 

  • src/Pugs/AST.hs-boot

    r15497 r21673  
    11{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -funbox-strict-fields -fallow-overlapping-instances #-} 
    22module Pugs.AST where 
    3 import Pugs.Internals.Cast 
     3import Pugs.Internals 
    44import Pugs.Types 
    55import Pugs.Class hiding (Val) 

  • src/Pugs/AST/Internals.hs

    r20058 r21673  
    7979    extractPlaceholderVars, fromObject, createObject, createObjectRaw, 
    8080    doPair, doHash, doArray, 
    81     unwrap, -- Unwrap(..) -- not used in this file, suitable for factoring out 
     81    unwrap, 
    8282    newObjectId, runInvokePerl5, 
    8383     
    … …  
    102102import Pugs.Cont (callCC) 
    103103import Pugs.Parser.Number 
     104import Pugs.AST.Types 
     105import Pugs.AST.Functions 
    104106import Pugs.AST.Eval 
    105107import Pugs.AST.Utils 
    … …  
    110112import Pugs.Embed.Perl5 
    111113import qualified Pugs.Val as Val 
    112 import qualified UTF8 as Str 
    113114import GHC.PArr 
    114115import {-# SOURCE #-} Pugs.AST 
    115116 
    116 {- <DrIFT> Imports for the DrIFT 
    117 import Pugs.AST.Scope 
    118 import Pugs.AST.Pos 
    119 import Pugs.AST.Prag 
    120 import Pugs.AST.SIO 
    121 import Pugs.Types 
    122 import Pugs.Internals 
    123 import Pugs.Embed.Perl5 
    124 import qualified Data.Set       as Set 
    125 import qualified Data.Map       as Map 
    126 import qualified Pugs.Val       as Val 
    127  
    128 import qualified Data.HashTable    as H 
    129  </DrIFT> -} 
    130   
     117-- CPP Includes 
     118 
    131119#include "../Types/Array.hs" 
    132120#include "../Types/Handle.hs" 
    … …  
    139127#include "../Types/Object.hs" 
    140128 
    141  
    142 catchT :: ((Val -> Eval b) -> Eval Val) -> Eval Val 
    143 catchT action = tryT (action retShift) 
     129-- Data Definitions 
     130 
     131{-| 
     132Represents a value. 
     133 
     134Note that 'Val' is also a constructor for 'Exp' (i.e. an expression containing  
     135a value), so don't confuse the two. Similarly, all the constructors for  
     136@data 'Val'@ are themselves puns on the types of values they contain. 
     137-} 
     138data Val 
     139    = VUndef                 -- ^ Undefined value 
     140    | VBool     !VBool       -- ^ Boolean value 
     141    | VInt      !VInt        -- ^ Integer value 
     142    | VRat      !VRat        -- ^ Rational number value 
     143    | VNum      !VNum        -- ^ Number (i.e. a double) 
     144    | VComplex  !VComplex    -- ^ Complex number value 
     145    | VStr      !VStr        -- ^ String value 
     146    | VList     !VList       -- ^ List value 
     147    | VType     !VType       -- ^ Type value (e.g. @Int@ or @Type@) 
     148    | VJunc     !VJunc       -- ^ Junction value 
     149    | VError    !Val ![Pos]  -- ^ Error 
     150    | VControl  !VControl 
     151------------------------------------------------------------------- 
     152-- The following are runtime-only values (VRef is negotiable) 
     153    | VRef      !VRef        -- ^ Reference value 
     154    | VCode     !VCode       -- ^ A code object 
     155    | VBlock    !VBlock 
     156    | VHandle   !VHandle     -- ^ File handle 
     157    | VSocket   !VSocket     -- ^ Socket handle 
     158    | VThread   !VThread 
     159    | VProcess  !VProcess    -- ^ PID value 
     160    | VRule     !VRule       -- ^ Rule\/regex value 
     161    | VSubst    !VSubst      -- ^ Substitution value (correct?) 
     162    | VMatch    !VMatch      -- ^ Match value 
     163    | VObject   !VObject     -- ^ Object 
     164    | VOpaque   !VOpaque 
     165    | PerlSV    !PerlSV 
     166    | VV        !Val.Val 
     167    deriving (Show, Eq, Ord, Typeable) 
     168 
     169{-| 
     170Evaluation environment. 
     171 
     172The current environment is stored in the @Reader@ monad inside the current  
     173'Eval' monad, and can be retrieved using @ask@ for the whole 'Env', or @asks@  
     174if you just want a single field. 
     175-} 
     176data Env = MkEnv 
     177    { envContext :: !Cxt                -- ^ Current context 
     178                                        -- ('CxtVoid', 'CxtItem' or 'CxtSlurpy') 
     179    , envLValue  :: !Bool               -- ^ Are we in an LValue context? 
     180    , envLexical :: !Pad                -- ^ Cached lexical pad for variable lookup 
     181    , envLexPads :: !LexPads            -- ^ Current lexical pads; MY is leftmost, OUTER is next, etc 
     182    , envCaller  :: !(Maybe Env)        -- ^ CALLER pads 
     183    , envCompPad :: !(Maybe MPad)       -- ^ Current COMPILING pad 
     184    , envGlobal  :: !MPad               -- ^ Global pad for variable lookup 
     185    , envPackage :: !Pkg                -- ^ Current package 
     186    , envEval    :: !(Exp -> Eval Val)  -- ^ Active evaluator 
     187    , envBody    :: !Exp                -- ^ Current AST expression 
     188    , envFrames  :: !(Set Frame)        -- ^ Special-markers in the dynamic path 
     189    , envDebug   :: !DebugInfo          -- ^ Debug info map 
     190    , envPos     :: !Pos                -- ^ Source position range 
     191    , envPragmas :: ![Pragma]           -- ^ List of pragmas in effect 
     192    , envInitDat :: !(TVar InitDat)     -- ^ BEGIN result information 
     193    , envMaxId   :: !(TVar ObjectId)    -- ^ Current max object id 
     194    , envAtomic  :: !Bool               -- ^ Are we in an atomic transaction? 
     195    }  
     196    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now 
     197 
     198data IVar v where 
     199    IScalar :: ScalarClass a => !a -> IVar VScalar 
     200    IArray  :: ArrayClass  a => !a -> IVar VArray 
     201    IHash   :: HashClass   a => !a -> IVar VHash 
     202    ICode   :: CodeClass   a => !a -> IVar VCode 
     203    IHandle :: HandleClass a => !a -> IVar VHandle 
     204    IRule   :: RuleClass   a => !a -> IVar VRule 
     205    IThunk  :: ThunkClass  a => !a -> IVar VThunk 
     206    IPair   :: PairClass   a => !a -> IVar VPair 
     207    IVal    ::                !Val -> IVar Val 
     208 
     209data VOpaque where 
     210    MkOpaque :: Value a => !a -> VOpaque 
     211 
     212-- GADTs, here we come! 
     213data VRef where 
     214    MkRef   :: (Typeable a) => !(IVar a) -> VRef 
     215 
     216data VObject = MkObject 
     217    { objType   :: !VType 
     218    , objAttrs  :: !IHash 
     219    , objOpaque :: !(Maybe Dynamic) 
     220    , objId     :: !ObjectId 
     221    } 
     222    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-} 
     223 
     224-- | Represents an expression tree. 
     225data Exp 
     226    = Noop                              -- ^ No-op 
     227    | App !Exp !(Maybe Exp) ![Exp]      -- ^ Function application 
     228                                        --     e.g. myfun($invocant: $arg) 
     229    | Syn !String ![Exp]                -- ^ Syntactic construct that cannot 
     230                                        --     be represented by 'App'. 
     231    | Ann !Ann !Exp                     -- ^ Annotation (see @Ann@) 
     232--  | Pad !Scope !Pad !Exp              -- ^ Lexical pad 
     233    | Sym !Scope !Var !EntryFlags !Exp !Exp -- ^ Symbol declaration 
     234    | Stmts !Exp !Exp                   -- ^ Multiple statements 
     235    | Prim !([Val] -> Eval Val)         -- ^ Primitive 
     236    | Val !Val                          -- ^ Value 
     237    | Var !Var                          -- ^ Variable 
     238    | NonTerm !Pos                      -- ^ Parse error 
     239    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-} 
     240 
     241newtype ObjectId = MkObjectId { unObjectId :: Int } 
     242    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos!-} 
     243 
     244-- Type Synonyms 
     245 
     246type VType = Type 
     247type VArray = [Val] 
     248type VHash = Map VStr Val 
     249type VList = [Val] 
     250 
     251-- Functions 
    144252 
    145253{-| 
    … …  
    152260        (return $ VList []) 
    153261        (return VUndef) 
     262 
     263retShiftEmpty :: Eval a 
     264retShiftEmpty = retShift =<< retEmpty 
    154265 
    155266evalValType :: Val -> Eval Type 
    … …  
    196307    bools <- mapM valToBool (Set.elems vs) 
    197308    return $ 1 == (length $ filter id bools) 
    198  
    199 instance Show JuncType where 
    200     show JAny  = "any" 
    201     show JAll  = "all" 
    202     show JNone = "none" 
    203     show JOne  = "one" 
    204  
    205 instance Show VJunc where 
    206     show (MkJunc jtype _ set) = 
    207         (show jtype) ++ "(" ++ 
    208             (foldl (\x y -> 
    209                 if x == "" then show y 
    210                 else x ++ "," ++ show y) 
    211             "" $ Set.elems set) ++ ")" 
    212  
    213 {-| 
    214 Typeclass indicating types that can be converted to\/from 'Val's. 
    215  
    216 Not to be confused with 'Val' itself, or the 'Exp' constructor @Val@. 
    217 -} 
    218 class (Typeable n, Show n, Ord n) => Value n where 
    219     fromVal :: Val -> Eval n 
    220     fromVal = fromVal' 
    221     doCast :: Val -> Eval n 
    222 {-    doCast v = castFailM v "default implementation of doCast" -} 
    223     fromVV :: Val.Val -> Eval n 
    224     fromVV v = do 
    225         str <- Val.asStr v 
    226         fail $ "Cannot cast from VV (" ++ cast str ++ ") to " ++ errType (undefined :: n) 
    227     fromSV :: PerlSV -> Eval n 
    228     fromSV sv = do 
    229         str <- io $ svToVStr sv 
    230         fail $ "Cannot cast from SV (" ++ str ++ ") to " ++ errType (undefined :: n) 
    231     castV :: n -> Val 
    232     castV x = VOpaque (MkOpaque x) -- error $ "Cannot cast into Val" 
    233  
    234 #ifndef HADDOCK 
    235 data VOpaque where 
    236     MkOpaque :: Value a => !a -> VOpaque 
    237 #endif 
    238309 
    239310fromVal' :: (Value a) => Val -> Eval a 
    … …  
    315386        } 
    316387 
     388 
     389runInvokePerl5 :: PerlSV -> PerlSV -> [PerlSV] -> Eval Val 
     390runInvokePerl5 sub inv args = do  
     391    env     <- ask 
     392    rv      <- io $ do 
     393        envSV   <- mkEnv env 
     394        invokePerl5 sub inv args envSV (enumCxt $ envContext env) 
     395    case rv of 
     396        Perl5ReturnValues [x]   -> io $ svToVal x 
     397        Perl5ReturnValues xs    -> io $ fmap VList (mapM svToVal xs) 
     398        Perl5ErrorString str    -> fail str 
     399        Perl5ErrorObject err    -> throwError (PerlSV err) 
     400 
     401anyToVal :: (Show a, Typeable a) => a -> Val 
     402anyToVal x 
     403    | Just v <- fromTypeable x      = v 
     404    | Just v <- fromTypeable x      = PerlSV v 
     405    | Just v <- fromTypeable x      = VStr v 
     406    | Just v <- fromTypeable x      = VInt v 
     407    | Just v <- fromTypeable x      = VNum v 
     408    | Just () <- fromTypeable x     = VUndef 
     409    | otherwise                     = error (show x) 
     410 
     411newSVval :: Val -> IO PerlSV 
     412newSVval val = case val of 
     413    PerlSV sv   -> return sv 
     414    VStr str    -> vstrToSV str 
     415    VType typ   -> vstrToSV (showType typ) 
     416    VBool bool  -> vintToSV (fromEnum bool) 
     417    VInt int    -> vintToSV int 
     418    VRat rat    -> vnumToSV rat 
     419    VNum num    -> vnumToSV num 
     420    VRef ref    -> vrefToSV ref 
     421    VCode{}     -> mkValRef val "Code" 
     422    VBlock{}    -> mkValRef val "Code" 
     423    VHandle{}   -> mkValRef val "Handle" 
     424    VSocket{}   -> mkValRef val "Socket" 
     425    VList{}     -> mkValRef val "Array" 
     426    VUndef      -> svUndef 
     427    VError{}    -> svUndef 
     428    _           -> mkValRef val "" 
     429 
     430vrefToSV :: VRef -> IO PerlSV 
     431vrefToSV ref = mkValRef (VRef ref) $ case ref of 
     432    MkRef IScalar{}   -> "Scalar" 
     433    MkRef IArray{}    -> "Array" 
     434    MkRef IHash{}     -> "Hash" 
     435    MkRef ICode{}     -> "Code" 
     436    MkRef IHandle{}   -> "Handle" 
     437    MkRef IRule{}     -> "Rule" 
     438    MkRef IThunk{}    -> "Thunk" 
     439    MkRef IPair{}     -> "Pair" 
     440    MkRef (IVal v)    -> show (valType v) 
     441 
     442valToStr :: Val -> Eval VStr 
     443valToStr = fromVal 
     444 
     445 
     446errStr :: VStr -> Val 
     447errStr str = VError (VStr str) [] 
     448 
     449errStrPos :: VStr -> Pos -> Val 
     450errStrPos str pos = VError (VStr str) [pos] 
     451 
     452errValPos :: Val -> Pos -> Val 
     453errValPos val pos = VError val [pos] 
     454 
     455enterAtomicEnv :: Env -> Env 
     456enterAtomicEnv env = env{ envAtomic = True } 
     457 
     458{-| 
     459Find the 'Type' of the value contained by a 'Val'. 
     460 
     461See "Pugs.Types" for info on types. 
     462-} 
     463valType :: Val -> Type 
     464valType VUndef          = mkType "Scalar" 
     465valType (VRef v)        = refType v 
     466valType (VBool    _)    = mkType "Bool" 
     467valType (VInt     _)    = mkType "Int" 
     468valType (VRat     _)    = mkType "Rat" 
     469valType (VNum     _)    = mkType "Num" 
     470valType (VComplex _)    = mkType "Complex" 
     471valType (VStr     _)    = mkType "Str" 
     472-- valType (VList    _)    = mkType "List" 
     473valType (VList    _)    = mkType "Array" 
     474valType (VCode    c)    = code_iType c 
     475valType (VBlock   _)    = mkType "Block" 
     476valType (VJunc    _)    = mkType "Junction" 
     477valType (VError _ _)    = mkType "Error" 
     478valType (VHandle  _)    = mkType "IO" 
     479valType (VSocket  _)    = mkType "Socket" 
     480valType (VThread  _)    = mkType "Thread" 
     481valType (VProcess _)    = mkType "Process" 
     482valType (VControl _)    = mkType "Control" 
     483valType (VRule    _)    = mkType "Regex" 
     484valType (VSubst   _)    = mkType "Subst" 
     485valType (VMatch   _)    = mkType "Match" 
     486valType (VType    t)    = t 
     487valType (VObject  o)    = objType o 
     488valType (VOpaque  _)    = mkType "Object" 
     489valType (PerlSV   _)    = mkType "Scalar::Perl5" 
     490valType (VV       _)    = mkType "Scalar::Perl5" -- (cast $ Val.valMeta v) 
     491 
     492valToBool :: Val -> Eval VBool 
     493valToBool = fromVal 
     494 
     495_Sym :: Scope -> String -> EntryFlags -> Exp -> Exp -> Exp 
     496_Sym scope str flags init rest = Sym scope (cast str) flags init rest 
     497 
     498_Var :: String -> Exp 
     499_Var str = Var (possiblyFixOperatorName (cast str)) 
     500 
     501-- Recursively apply a transformation to an Exp structure 
     502transformExp :: (Monad m) => (Exp -> m Exp) -> Exp -> m Exp 
     503transformExp f (App a b cs) = do 
     504    a' <- transformExp f a 
     505    b' <- case b of 
     506        Just e -> liftM Just $ transformExp f e 
     507        Nothing -> return Nothing 
     508    cs' <- mapM (transformExp f) cs 
     509    f $ App a' b' cs' 
     510transformExp f (Syn t es) = f =<< liftM (Syn t) (mapM (transformExp f) es) 
     511transformExp f (Ann a e) = f =<< liftM (Ann a) (transformExp f e) 
     512-- transformExp f (Pad s p e) = f =<< liftM (Pad s p) (transformExp f e) 
     513transformExp f (Sym s v c i e) = f =<< liftM (Sym s v c i) (transformExp f e) 
     514transformExp f (Stmts e1 e2) = do  
     515    e1' <- transformExp f e1 
     516    e2' <- transformExp f e2 
     517    f $ Stmts e1' e2' 
     518transformExp f e = f e 
     519 
     520{- FIXME: Figure out how to get this working without a monad, and make it castV -} 
     521expToEvalVal :: Exp -> Eval Val 
     522expToEvalVal exp = do 
     523    obj <- createObject (mkType "Code::Exp") [] 
     524    return $ VObject obj{ objOpaque = Just $ toDyn exp } 
     525 
     526fromVals :: (Value n) => Val -> Eval [n] 
     527fromVals v = mapM fromVal =<< fromVal v 
     528 
     529extractPlaceholderVarsExp :: Exp -> ([Exp], Set Var) -> ([Exp], Set Var) 
     530extractPlaceholderVarsExp ex (exps, vs) = (ex':exps, vs') 
     531    where 
     532    (ex', vs') = extractPlaceholderVars ex vs 
     533 
     534{-| Deduce the placeholder vars ($^a, $^x etc.) used by a block). -} 
     535extractPlaceholderVars :: Exp -> Set Var -> (Exp, Set Var) 
     536extractPlaceholderVars (App n invs args) vs = (App n' invs' args', vs''') 
     537    where 
     538    (n', vs')      = extractPlaceholderVars n vs 
     539    (invs', vs'')  = maybe (invs, vs') (\inv -> let (x, y) = extractPlaceholderVars inv vs' in (Just x, y)) invs 
     540    (args', vs''') = foldr extractPlaceholderVarsExp ([], vs'') args 
     541extractPlaceholderVars (Stmts exp1 exp2) vs = (Stmts exp1' exp2', vs'') 
     542    where 
     543    (exp1', vs')  = extractPlaceholderVars exp1 vs 
     544    (exp2', vs'') = extractPlaceholderVars exp2 vs' 
     545extractPlaceholderVars (Syn n exps) vs = (Syn n exps', vs'') 
     546    where 
     547    (exps', vs') = foldr extractPlaceholderVarsExp ([], vs) exps 
     548    vs'' = case n of 
     549        "when"  -> Set.insert (cast "$_") vs' 
     550        "given" -> Set.delete (cast "$_") vs' 
     551        _       -> vs' 
     552extractPlaceholderVars (Var var) vs 
     553    | TImplicit <- v_twigil var 
     554    , var' <- var{ v_twigil = TNil } 
     555    = (Var var', Set.insert var' vs) 
     556    | var == cast "$_" 
     557    = (Var var, Set.insert var vs) 
     558    | otherwise 
     559    = (Var var, vs) 
     560extractPlaceholderVars (Ann ann ex) vs = ((Ann ann ex'), vs') 
     561    where 
     562    (ex', vs') = extractPlaceholderVars ex vs 
     563-- extractPlaceholderVars (Pad scope pad ex) vs = ((Pad scope pad ex'), vs') 
     564--     where 
     565--     (ex', vs') = extractPlaceholderVars ex vs 
     566extractPlaceholderVars (Sym scope var flags ini ex) vs = ((Sym scope var flags ini ex'), vs') 
     567    where 
     568    (ex', vs') = extractPlaceholderVars ex vs 
     569extractPlaceholderVars exp vs = (exp, vs) 
     570 
     571envPos' :: Env -> Pos 
     572envPos' = envPos 
     573 
     574envWant :: Env -> String 
     575envWant env = 
     576    showCxt (envContext env) ++ (if envLValue env then ", LValue" else "") 
     577    where 
     578    showCxt CxtVoid         = "Void" 
     579    showCxt (CxtItem typ)   = "Scalar (" ++ showType typ ++ ")" 
     580    showCxt (CxtSlurpy typ) = "List (" ++ showType typ ++ ")" 
     581 
     582refreshPad :: Pad -> Eval Pad 
     583refreshPad pad = do 
     584    fmap listToPad $ forM (padToList pad) $ \(name, entry) -> do 
     585        -- warn "Refreshing pad entry" (name, entry) 
     586        entry' <- case entry of 
     587            PELexical{ pe_proto = proto } -> stm $ do 
     588                ref     <- cloneRef proto 
     589                tvar'   <- newTVar ref 
     590                return entry{ pe_store = tvar' } 
     591            _ -> return entry 
     592        return (name, entry') 
     593 
     594{-| 
     595Retrieve the global 'Pad' from the current evaluation environment. 
     596 
     597'Env' stores the global 'Pad' in an STM variable, so we have to @asks@ 
     598'Eval'\'s @ReaderT@ for the variable, then extract the pad itself from the 
     599STM var. 
     600-} 
     601askGlobal :: Eval Pad 
     602askGlobal = do 
     603    glob <- asks (mp_pad . envGlobal) 
     604    stm $ readTVar glob 
     605 
     606writeVar :: Var -> Val -> Eval () 
     607writeVar var val 
     608    | isLexicalVar var  = doWriteVar (asks envLexical) 
     609    | otherwise         = doWriteVar askGlobal 
     610    where 
     611    doWriteVar askPad = do 
     612        pad <- askPad 
     613        case lookupPad var pad of 
     614            Just PEConstant{} -> fail $ "Cannot rebind constant: " ++ show var 
     615            Just c -> do 
     616                ref <- stm $ readTVar (pe_store c) 
     617                writeRef ref val 
     618            _  -> fail $ "Cannot bind to non-existing variable: " ++ show var 
     619 
     620readVar :: Var -> Eval Val 
     621readVar var 
     622    | isLexicalVar var = do 
     623        lex <- asks envLexical 
     624        case findSym var lex of 
     625            Just action -> stm action >>= readRef 
     626            _           -> return undef 
     627    | otherwise = do 
     628        glob <- askGlobal 
     629        case findSym var glob of 
     630            Just action -> stm action >>= readRef 
     631            _           -> return undef 
     632 
     633{-| 
     634The \'empty expression\' is just a no-op ('Noop'). 
     635-} 
     636emptyExp :: Exp 
     637emptyExp = Noop 
     638 
     639retControl :: VControl -> Eval a 
     640retControl = retShift . VControl 
     641 
     642defined :: VScalar -> Bool 
     643defined VUndef  = False 
     644defined VType{} = False 
     645defined _       = True 
     646-- | Produce an undefined Perl 6 value (i.e. 'VUndef'). 
     647undef :: VScalar 
     648undef = VUndef 
     649 
     650forceRef :: VRef -> Eval Val 
     651forceRef (MkRef (IScalar sv)) = forceRef =<< fromVal =<< scalar_fetch sv 
     652forceRef (MkRef (IThunk tv)) = thunk_force tv 
     653forceRef r = die "Cannot forceRef" r 
     654 
     655dumpRef :: VRef -> Eval Val 
     656dumpRef (MkRef (ICode cv)) = do 
     657    vsub <- code_fetch cv 
     658    return (VStr $ "(MkRef (ICode $ " ++ show vsub ++ "))") 
     659dumpRef (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" = do 
     660    sv <- scalar_fetch sv 
     661    return (VStr $ "(MkRef (IScalar $ " ++ show sv ++ "))") 
     662dumpRef ref = return (VStr $ "(unsafePerformIO . newObject $ mkType \"" ++ showType (refType ref) ++ "\")") 
     663 
     664-- Reduce a VRef in rvalue context.  
     665readRef :: VRef -> Eval Val 
     666readRef (MkRef (IScalar sv)) = scalar_fetch sv 
     667readRef (MkRef (ICode cv)) = do 
     668    vsub <- code_fetch cv 
     669    return $ VCode vsub 
     670readRef (MkRef (IHash hv)) = do 
     671    pairs <- hash_fetch hv 
     672    return $ VList $ map (\(k, v) -> castV (castV k, v)) (Map.assocs pairs) 
     673readRef (MkRef (IArray av)) = do 
     674    vals <- array_fetch av 
     675    return $ VList vals 
     676 
     677-- XXX - This case is entirely bogus; but no time to fix it now. 
     678readRef (MkRef (IPair pv)) = do 
     679    (k, v) <- pair_fetch pv 
     680    return $ VList [k, v] 
     681 
     682readRef (MkRef (IHandle io)) = return . VHandle =<< handle_fetch io 
     683readRef (MkRef (IRule rx)) = return . VRule =<< rule_fetch rx 
     684readRef (MkRef (IThunk tv)) = readRef =<< fromVal =<< thunk_force tv 
     685readRef (MkRef (IVal v)) = do 
     686    cxt <- asks envContext 
     687    v ./ cxt 
     688 
     689retIVar :: (Typeable a) => IVar a -> Eval Val 
     690retIVar = return . VRef . MkRef 
     691 
     692fromVList :: Val -> Eval VArray 
     693fromVList (VList v) = return v 
     694fromVList x = return [x] 
     695 
     696fromVHash :: Val -> Eval VHash 
     697fromVHash = fromVal 
     698 
     699writeRef :: VRef -> Val -> Eval () 
     700writeRef (MkRef (IScalar s)) (VList vals) = do 
     701    av <- newArray vals 
     702    scalar_store s (VRef $ MkRef av) 
     703writeRef (MkRef (IScalar s)) val = scalar_store s val 
     704writeRef (MkRef (IArray s)) val  = array_store s =<< fromVList val 
     705writeRef (MkRef (IHash s)) val   = hash_store s =<< fromVHash val 
     706writeRef (MkRef (ICode s)) val   = code_store s =<< fromVal val 
     707writeRef (MkRef (IPair s)) val   = pair_storeVal s val 
     708writeRef (MkRef (IThunk tv)) val = (`writeRef` val) =<< fromVal =<< thunk_force tv 
     709writeRef r _ = die "Cannot writeRef" r 
     710 
     711cloneRef :: VRef -> STM VRef 
     712cloneRef (MkRef x) = fmap MkRef (cloneIVar x) 
     713 
     714clearRef :: VRef -> Eval () 
     715clearRef (MkRef (IScalar s)) = scalar_store s undef 
     716clearRef (MkRef (IArray s))  = array_clear s 
     717clearRef (MkRef (IHash s))   = hash_clear s 
     718clearRef (MkRef (IPair s))   = pair_storeVal s undef 
     719clearRef (MkRef (IThunk tv)) = clearRef =<< fromVal =<< thunk_force tv 
     720clearRef r = die "Cannot clearRef" r 
     721 
     722{-# SPECIALISE newObject :: Type -> Eval VRef #-} 
     723{-# SPECIALISE newObject :: Type -> IO VRef #-} 
     724newObject :: (MonadSTM m, MonadIO m) => Type -> m VRef 
     725newObject typ = case showType typ of 
     726    "Any"       -> io $ fmap scalarRef $ newTVarIO undef 
     727    "Item"      -> io $ fmap scalarRef $ newTVarIO undef 
     728    "Scalar"    -> io $ fmap scalarRef $ newTVarIO undef 
     729    "Array"     -> io $ do 
     730        iv  <- newTVarIO [::] 
     731        return $ arrayRef (MkIArray iv) 
     732    "Hash"      -> do 
     733        h   <- io (H.new (==) H.hashString) 
     734        return $ hashRef (h :: IHash) 
     735    "Sub"       -> newObject $ mkType "Code" 
     736    "Routine"   -> newObject $ mkType "Code" 
     737    "Method"    -> newObject $ mkType "Code" 
     738    "Submethod" -> newObject $ mkType "Code" 
     739    "Code"      -> return $! codeRef $ mkPrim 
     740        { subAssoc = AIrrelevantToParsing 
     741        , subBody  = Prim . const $ fail "Cannot use Undef as a Code object" 
     742        } 
     743    "Type"      -> io $ fmap scalarRef $ newTVarIO undef 
     744    "Pair"      -> do 
     745        key <- newObject (mkType "Scalar") 
     746        val <- newObject (mkType "Scalar") 
     747        return $ MkRef (IPair (VRef key, VRef val)) 
     748    "Regex"     -> io $ fmap scalarRef $ newTVarIO undef -- XXX Wrong 
     749    "Capture"   -> io $ fmap scalarRef $ newTVarIO undef -- XXX Wrong 
     750    _           -> fail ("Class prototype occured where its instance object expected: " ++ showType typ) 
     751 
     752doPair :: Val -> (forall a. PairClass a => a -> b) -> Eval b 
     753doPair (VRef (MkRef (IPair pv))) f = return $ f pv 
     754doPair (VRef (MkRef (IHash hv))) f = do 
     755    vals <- hash_fetch hv 
     756    let [(k, v)] = Map.toList vals 
     757    return $ f (VStr k, v) 
     758doPair (VRef (MkRef (IArray av))) f = do 
     759    vals <- array_fetch av 
     760    let [k, v] = take 2 (vals ++ repeat undef) 
     761    return $ f (k, v) 
     762doPair (VRef (MkRef (IScalar sv))) f = do 
     763    val <- scalar_fetch sv 
     764    case val of 
     765        VUndef  -> do 
     766            ref@(MkRef (IPair pv)) <- newObject (mkType "Pair") 
     767            scalar_store sv (VRef ref) 
     768            return $ f pv 
     769        _  -> doPair val f 
     770doPair (VRef x) _ = die "Cannot cast into Pair" x 
     771doPair val f = do 
     772    vs <- fromVal val 
     773    case (vs :: VList) of 
     774        [x, y]  -> return $ f (x, y)