Changeset 15297

Show
Ignore:
Timestamp:
02/18/07 15:59:02 (21 months ago)
Author:
audreyt
Message:

* Revert the previous patch; everything back to normal.

Files:
47 modified

Legend:

Unmodified
Added
Removed

  • examples/mandel.pl

    r12488 r15297  
    3535    last() if $L > 0; 
    3636    loop ($y=30; $P = $y * 0.1, $C = $P - 1.5;) { 
    37         last() if $y < 0; 
     37        last() if $y < 27; 
    3838        $y--; 
    3939        loop ($x=0; $P = $x * 0.04, $c = $P - 2, $z=0.0, $Z=0.0;) { 

  • src/Pugs.hs

    r15296 r15297  
    312312    return () 
    313313    where 
    314     exp = App (_Var "&require") Nothing [Val $ _VStr fn] 
     314    exp = App (_Var "&require") Nothing [Val $ VStr fn] 
    315315 
    316316doRunSingle :: TVar Env -> RunOptions -> String -> IO () 
    … …  
    354354        Val err@(VError (VStr msg) _) 
    355355            | runOptShowPretty opts 
    356             , any (== "Unexpected end of input") (lines (cast msg)) -> do 
     356            , any (== "Unexpected end of input") (lines msg) -> do 
    357357            cont <- readline "....> " 
    358358            case cont of 
    … …  
    365365        _ -> return $ makeDumpEnv exp 
    366366    -- XXX Generalize this into structural folding 
    367     makeDumpEnv Noop              = _Syn "continuation" [] 
    368     makeDumpEnv (Stmts x Noop)    = Stmts x   (_Syn "continuation" []) 
     367    makeDumpEnv Noop              = Syn "continuation" [] 
     368    makeDumpEnv (Stmts x Noop)    = Stmts x   (Syn "continuation" []) 
    369369    makeDumpEnv (Stmts x exp)     = Stmts x   $ makeDumpEnv exp 
    370370    makeDumpEnv (Ann ann exp)     = Ann ann   $ makeDumpEnv exp 
    371371    makeDumpEnv (Pad x y exp)     = Pad x y   $ makeDumpEnv exp 
    372372    makeDumpEnv (Sym x y exp)     = Sym x y   $ makeDumpEnv exp 
    373     makeDumpEnv exp = Stmts exp (_Syn "continuation" []) 
     373    makeDumpEnv exp = Stmts exp (Syn "continuation" []) 
    374374    handler (IOException ioe) | isUserError ioe = do 
    375375        putStrLn "Internal error while running expression:" 
    … …  
    405405 
    406406runProgramWith :: 
    407     (Env -> Env) -> (Val -> IO a) -> String -> [String] -> String -> IO a 
     407    (Env -> Env) -> (Val -> IO a) -> VStr -> [VStr] -> String -> IO a 
    408408runProgramWith fenv f name args prog = do 
    409409    env <- prepareEnv name args 

  • src/Pugs/AST.hs

    r15296 r15297  
    1 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields -fallow-overlapping-instances -foverloaded-strings #-} 
     1{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields -fallow-overlapping-instances #-} 
    22 
    33{-| 
    … …  
    216216mergeStmts x y = Stmts x y 
    217217 
    218 isImplicitTopic :: ID -> Bool 
     218isImplicitTopic :: String -> Bool 
    219219isImplicitTopic "subst" = True 
    220220isImplicitTopic "match" = True 
    … …  
    234234 
    235235_underscore :: ID 
    236 _underscore = _cast "_" 
     236_underscore = cast "_"  
    237237 
    238238newPackage :: String -> String -> [String] -> [String] -> Exp 
    … …  
    244244            (Just $ Val (VType $ mkType cls)) 
    245245            [ Syn "named" 
    246                 [ Val (_VStr "is") 
    247                 , Val (VList $ map castV classes) 
     246                [ Val (VStr "is") 
     247                , Val (VList $ map VStr classes) 
    248248                ] 
    249249            , Syn "named" 
    250                 [ Val (_VStr "does") 
    251                 , Val (VList $ map castV roles) 
     250                [ Val (VStr "does") 
     251                , Val (VList $ map VStr roles) 
    252252                ] 
    253253            , Syn "named" 
    254                 [ Val (_VStr "name") 
    255                 , Val (castV name) 
     254                [ Val (VStr "name") 
     255                , Val (VStr name) 
    256256                ] 
    257257            , Syn "named" 
    258                 [ Val (_VStr "attrs") 
     258                [ Val (VStr "attrs") 
    259259                , Syn "\\{}" [Noop] 
    260260                ] 

  • src/Pugs/AST/Eval.hs

    r15296 r15297  
    102102 
    103103instance Monad Eval where 
    104     {-# INLINE return #-} 
    105     return a = EvalT (return (RNormal a)) 
    106     {-# INLINE (>>=) #-} 
    107     m >>= k = EvalT (do 
     104    return a = EvalT $ return (RNormal a) 
     105    m >>= k = EvalT $ do 
    108106        a <- runEvalT m 
    109107        case a of 
    110             RNormal x       -> runEvalT $! k x 
    111             RException x    -> return (RException x)) 
    112     {-# INLINE fail #-} 
     108            RNormal x   -> runEvalT (k x) 
     109            RException x-> return (RException x) 
    113110    fail str = do 
    114111        pos <- asks envPos' 
    115         EvalT (return (RException (errStrPos (cast str) pos))) 
     112        EvalT $ return (RException (errStrPos (cast str) pos)) 
    116113 
    117114instance Error Val where 
    118     noMsg = errStr (_cast "") 
    119     strMsg = errStr . _cast 
     115    noMsg = errStr "" 
     116    strMsg = errStr 
    120117 
    121118instance MonadTrans EvalT where 
    … …  
    189186instance MonadReader Env Eval where 
    190187    ask       = lift ask 
    191     local f m = EvalT (local f (runEvalT m)) 
     188    local f m = EvalT $ local f (runEvalT m) 
    192189 
    193190instance MonadCont Eval where 

  • src/Pugs/AST/Internals.hs

    r15296 r15297  
    1 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr -foverloaded-strings #-} 
     1{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr #-} 
    22 
    33module Pugs.AST.Internals ( 
    … …  
    8282    newSVval, -- used in Run.Perl5 
    8383 
    84     DebugInfo, _Syn, _Sym, _Var, _VStr -- String -> ByteString constructors 
     84    DebugInfo, _Sym, _Var -- String -> ByteString constructors 
    8585) where 
    8686 
    … …  
    281281    => ObjectId -> Maybe Dynamic -> VType -> [(VStr, Val)] -> m VObject 
    282282createObjectRaw uniq opaq typ attrList = do 
    283     attrs   <- liftSTM . unsafeIOToSTM . hashList $ map (\(a,b) -> (a, lazyScalar b)) attrList 
     283    attrs   <- liftSTM . unsafeIOToSTM . H.fromList H.hashString $ map (\(a,b) -> (a, lazyScalar b)) attrList 
    284284    return $ MkObject 
    285285        { objType   = typ 
    … …  
    324324        mapM fromVal vlist 
    325325    doCast v = castFailM v "[Int]" 
    326  
    327 instance Value [String] where 
    328     castV = VList . map _VStr 
    329     fromVal v = do 
    330         vlist <- fromVal v 
    331         mapM fromVal vlist 
    332     doCast v = castFailM v "[String]" 
    333326 
    334327instance Value [VStr] where 
    … …  
    392385    castV = VCode 
    393386    fromSV sv = return $ mkPrim 
    394         { subName     = cast ("<anon>" :: String) 
     387        { subName     = cast "<anon>" 
    395388        , subParams   = [defaultArrayParam] 
    396389        , subReturns  = mkType "Scalar::Perl5" 
    … …  
    455448    doCast (VBool b)    = return $ if b then 1 % 1 else 0 % 1 
    456449    doCast (VList l)    = return $ genericLength l 
    457     doCast (VStr s) | not (Str.null s), isSpace $ Str.last s = do 
    458         str <- fromVal (castV $ Str.init s) 
     450    doCast (VStr s) | not (null s) , isSpace $ last s = do 
     451        str <- fromVal (VStr $ init s) 
    459452        return str 
    460     doCast (VStr s) | not (Str.null s), isSpace $ Str.head s = do  
    461         str <- fromVal (castV $ Str.tail s) 
     453    doCast (VStr s) | not (null s) , isSpace $ head s = do  
     454        str <- fromVal (VStr $ tail s) 
    462455        return str 
    463456    doCast (VStr s)     = return $ 
    464         case parseNatOrRat (cast s) of 
     457        case ( parseNatOrRat s ) of 
    465458            Left _   -> 0 % 1 
    466459            Right rv -> case rv of 
    … …  
    480473    doCast (VNum n)     = return $ n 
    481474    doCast (VComplex (r :+ _)) = return $ r 
    482     doCast (VStr s) | not (Str.null s), isSpace $ Str.last s = do 
    483         str <- fromVal (castV $ Str.init s) 
     475    doCast (VStr s) | not (null s) , isSpace $ last s = do 
     476        str <- fromVal (VStr $ init s) 
    484477        return str 
    485     doCast (VStr s) | not (Str.null s), isSpace $ Str.head s = do 
    486         str <- fromVal (castV $ Str.tail s) 
     478    doCast (VStr s) | not (null s) , isSpace $ head s = do 
     479        str <- fromVal (VStr $ tail s) 
    487480        return str 
    488481    doCast (VStr "Inf") = return $ 1/0 
    … …  
    490483    doCast (VStr "NaN") = return $ 0/0 
    491484    doCast (VStr s)     = return $ 
    492         case ( parseNatOrRat (cast s) ) of 
     485        case ( parseNatOrRat s ) of 
    493486            Left _   -> 0 
    494487            Right rv -> case rv of 
    … …  
    527520instance Value VStr where 
    528521    castV = VStr 
    529     fromSV sv = fmap cast (liftIO $ svToVStr sv) 
    530     fromVV vv = liftSIO $ cast (Val.asStr vv) 
    531     fromVal (VList l)    = return . Str.unwords =<< mapM fromVal l 
    532     fromVal v@(PerlSV _) = fromVal' v 
    533     fromVal VUndef       = return (__"") 
    534     fromVal (VType t)    = return (cast t) 
    535     fromVal v = do 
    536         vt  <- evalValType v 
    537         case vt of 
    538             MkType "Pair" -> do 
    539                 -- Special case for pairs: "$pair" eq 
    540                 -- "$pair.key()\t$pair.value()" 
    541                 (k, v)  <- join $ doPair v pair_fetch 
    542                 k'      <- fromVal k 
    543                 v'      <- fromVal v 
    544                 return $ k' +++ __"\t" +++ v' 
    545             MkType "Hash" -> do 
    546                 --- XXX special case for Hash -- need to Objectify 
    547                 hv      <- join $ doHash v hash_fetch 
    548                 lns     <- forM (Map.assocs hv) $ \(k, v) -> do 
    549                     str <- fromVal v 
    550                     return $ k +++ __"\t" +++ str 
    551                 return $ Str.unlines lns 
    552             _ -> fromVal' v 
    553     doCast VUndef        = return $ __"" 
    554     doCast VType{}       = return $ __"" 
    555     doCast (VStr s)      = return s 
    556     doCast (VBool b)     = return $ if b then __"1" else __"" 
    557     doCast (VInt i)      = return $ __(show i) 
    558     doCast (VRat r)      = return $ __(showRat r) 
    559     doCast (VNum n)      = return $ __(showNum n) 
    560     doCast (VComplex (r :+ i)) = return $ __(showNum r ++ " + " ++ showNum i ++ "i") 
    561     doCast (VList l)     = fmap Str.unwords (mapM fromVal l) 
    562     doCast (VCode s)     = return $ __("<" ++ show (subType s) ++ "(" ++ cast (subName s) ++ ")>") 
    563     doCast (VJunc j)     = return $ __(show j) 
    564     doCast (VThread t)   = return $ __(takeWhile isDigit $ dropWhile (not . isDigit) $ show t) 
    565     doCast (VHandle h)   = return $ __"<VHandle (" +++ __(show h) +++ __">" 
    566     doCast (VMatch m)    = return $ matchStr m 
    567  -- doCast (VType typ)   = return $ showType typ -- "::" ++ showType typ 
    568     doCast (VObject o)   = return $ __"<obj:" +++ cast (objType o) +++ __">" 
    569     doCast x             = return $ __"<" +++ cast (valType x) +++ __">" 
    570  
    571 instance Value String where 
    572     castV = VStr . cast 
    573522    fromSV sv = liftIO $ svToVStr sv 
    574523    fromVV vv = liftSIO $ cast (Val.asStr vv) 
    … …  
    592541                lns     <- forM (Map.assocs hv) $ \(k, v) -> do 
    593542                    str <- fromVal v 
    594                     return $ k +++ __"\t" +++ str 
    595                 return $ unlines (cast lns) 
     543                    return $ k ++ "\t" ++ str 
     544                return $ unlines lns 
    596545            _ -> fromVal' v 
    597546    doCast VUndef        = return "" 
    598547    doCast VType{}       = return "" 
    599     doCast (VStr s)      = return (cast s) 
     548    doCast (VStr s)      = return s 
    600549    doCast (VBool b)     = return $ if b then "1" else "" 
    601550    doCast (VInt i)      = return $ show i 
    … …  
    608557    doCast (VThread t)   = return $ takeWhile isDigit $ dropWhile (not . isDigit) $ show t 
    609558    doCast (VHandle h)   = return $ "<" ++ "VHandle (" ++ (show h) ++ ">" 
    610     doCast (VMatch m)    = return $ (cast (matchStr m)) 
     559    doCast (VMatch m)    = return $ matchStr m 
    611560 -- doCast (VType typ)   = return $ showType typ -- "::" ++ showType typ 
    612561    doCast (VObject o)   = return $ "<obj:" ++ showType (objType o) ++ ">" 
    … …  
    625574newSVval val = case val of 
    626575    PerlSV sv   -> return sv 
    627     VStr str    -> bufToSV str 
     576    VStr str    -> vstrToSV str 
    628577    VType typ   -> vstrToSV (showType typ) 
    629578    VBool bool  -> vintToSV (fromEnum bool) 
    … …  
    10691018mkPrim = MkCode 
    10701019    { isMulti = True 
    1071     , subName = cast ("&" :: String) 
     1020    , subName = cast "&" 
    10721021    , subType = SubPrim 
    10731022    , subEnv = Nothing 
    … …  
    10961045mkSub = MkCode 
    10971046    { isMulti = False 
    1098     , subName = cast ("&" :: String) 
     1047    , subName = cast "&" 
    10991048    , subType = SubBlock 
    11001049    , subEnv = Nothing 
    … …  
    11231072mkCode = MkCode 
    11241073    { isMulti = False 
    1125     , subName = cast ("&" :: String) 
     1074    , subName = cast "&" 
    11261075    , subType = SubBlock 
    11271076    , subEnv = Nothing 
    … …  
    11811130    | App !Exp !(Maybe Exp) ![Exp]      -- ^ Function application 
    11821131                                        --     e.g. myfun($invocant: $arg) 
    1183     | Syn !ID ![Exp]                    -- ^ Syntactic construct that cannot 
     1132    | Syn !String ![Exp]                -- ^ Syntactic construct that cannot 
    11841133                                        --     be represented by 'App'. 
    11851134    | Ann !Ann !Exp                     -- ^ Annotation (see @Ann@) 
    … …  
    11981147_Var :: String -> Exp 
    11991148_Var str = Var (possiblyFixOperatorName (cast str)) 
    1200  
    1201 _VStr :: String -> Val 
    1202 _VStr = VStr . cast 
    1203  
    1204 _Syn :: String -> [Exp] -> Exp 
    1205 _Syn s xs = Syn (cast s) xs 
    12061149 
    12071150instance Value Exp where 
    … …  
    12901233    (exps', vs') = foldr extractPlaceholderVarsExp ([], vs) exps 
    12911234    vs'' = case n of 
    1292         "when"  -> Set.insert varTopic vs' 
    1293         "given" -> Set.delete varTopic vs' 
     1235        "when"  -> Set.insert (cast "$_") vs' 
     1236        "given" -> Set.delete (cast "$_") vs' 
    12941237        _       -> vs' 
    12951238extractPlaceholderVars (Var var) vs 
    … …  
    12971240    , var' <- var{ v_twigil = TNil } 
    12981241    = (Var var', Set.insert var' vs) 
    1299     | var == varTopic 
     1242    | var == cast "$_" 
    13001243    = (Var var, Set.insert var vs) 
    13011244    | otherwise 
    … …  
    13391282defaultArrayParam   = buildParam "" "*" "@_" (Val VUndef) 
    13401283defaultHashParam    = buildParam "" "*" "%_" (Val VUndef) 
    1341 defaultScalarParam  = buildParam "" "?" "$_" (_Var "$_") 
     1284defaultScalarParam  = buildParam "" "?" "$_" (Var $ cast "$_") 
    13421285 
    13431286type DebugInfo = Maybe (TVar (Map ID String)) 
    … …  
    16141557dumpRef (MkRef (ICode cv)) = do 
    16151558    vsub <- code_assuming cv [] [] 
    1616     return (castV $ "(MkRef (ICode $ " ++ show vsub ++ "))") 
     1559    return (VStr $ "(MkRef (ICode $ " ++ show vsub ++ "))") 
    16171560dumpRef (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" = do 
    16181561    sv <- scalar_fetch sv 
    1619     return (castV $ "(MkRef (IScalar $ " ++ show sv ++ "))") 
    1620 dumpRef ref = return (castV $ "(unsafePerformIO . newObject $ mkType \"" ++ showType (refType ref) ++ "\")") 
     1562    return (VStr $ "(MkRef (IScalar $ " ++ show sv ++ "))") 
     1563dumpRef ref = return (VStr $ "(unsafePerformIO . newObject $ mkType \"" ++ showType (refType ref) ++ "\")") 
    16211564 
    16221565readRef :: VRef -> Eval Val 
    … …  
    16811624        return $ arrayRef (MkIArray iv) 
    16821625    "Hash"      -> do 
    1683         h   <- liftIO hashNew 
     1626        h   <- liftIO (H.new (==) H.hashString) 
    16841627        return $ hashRef (h :: IHash) 
    16851628    "Code"      -> return $! codeRef $ mkPrim 
    … …  
    19111854newHash hash = do 
    19121855    --liftSTM $ unsafeIOToSTM $ putStrLn "new hash" 
    1913     ihash <- liftSTM . unsafeIOToSTM $ hashList (map (\(a,b) -> (a, lazyScalar b)) (Map.toList hash)) 
     1856    ihash <- liftSTM . unsafeIOToSTM $ H.fromList H.hashString (map (\(a,b) -> (a, lazyScalar b)) (Map.toList hash)) 
    19141857    return $ IHash ihash 
    19151858 
    … …  
    20121955        , envLValue  = False 
    20131956        , envGlobal  = glob 
    2014         , envPackage = _cast "Main" 
     1957        , envPackage = cast "Main" 
    20151958        , envClasses = initTree 
    20161959        , envEval    = const (return VUndef) 
    … …  
    20431986    asYAML x = asYAMLmap "Map" $ Map.toAscList (Map.map asYAML x) 
    20441987    fromYAML node = fmap Map.fromList (fromYAMLmap node) 
    2045 instance YAML a => YAML (Map ByteString a) where 
    2046     asYAML x = asYAMLmapBuf "Map" $ Map.toAscList (Map.map asYAML x) 
    2047     fromYAML node = fmap Map.fromList (fromYAMLmapBuf node) 
    20481988instance YAML a => YAML (Map Var a) where 
    20491989    asYAML x = asYAMLmap "Map" . sortBy (\x y -> fst x `compare` fst y) $ 
    … …  
    20982038     asYAML x = do 
    20992039         l      <- liftIO $ H.toList x 
    2100          asYAMLmapBuf "IHash" (map (\(k, v) -> (k, asYAML v)) l) 
     2040         asYAMLmap "IHash" (map (\(k, v) -> (k, asYAML v)) l) 
    21012041     fromYAML node = do 
    2102          l  <- fromYAMLmapBuf node 
    2103          l' <- hashList l 
     2042         l  <- fromYAMLmap node 
     2043         l' <- H.fromList H.hashString l 
    21042044         return l' 
    21052045 

  • src/Pugs/AST/Internals/Instances.hs

    r15296 r15297  
    1 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr -foverloaded-strings #-} 
     1{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -fallow-undecidable-instances -fparr #-} 
    22 
    33 
    … …  
    6363        , envLValue  = False 
    6464        , envGlobal  = glob 
    65         , envPackage = _cast "Main" 
     65        , envPackage = cast "Main" 
    6666        , envClasses = initTree 
    6767        , envEval    = const (return VUndef) 
    … …  
    9494    asYAML x = asYAMLmap "Map" $ Map.toAscList (Map.map asYAML x) 
    9595    fromYAML node = fmap Map.fromList (fromYAMLmap node) 
    96 instance YAML a => YAML (Map ByteString a) where 
    97     asYAML x = asYAMLmapBuf "Map" $ Map.toAscList (Map.map asYAML x) 
    98     fromYAML node = fmap Map.fromList (fromYAMLmapBuf node) 
    9996instance YAML a => YAML (Map Var a) where 
    10097    asYAML x = asYAMLmap "Map" . sortBy (\x y -> fst x `compare` fst y) $ 
    … …  
    149146     asYAML x = do 
    150147         l      <- liftIO $ H.toList x 
    151          asYAMLmapBuf "IHash" (map (\(k, v) -> (k, asYAML v)) l) 
     148         asYAMLmap "IHash" (map (\(k, v) -> (k, asYAML v)) l) 
    152149     fromYAML node = do 
    153          l  <- fromYAMLmapBuf node 
    154          l' <- hashList l 
     150         l  <- fromYAMLmap node 
     151         l' <- H.fromList H.hashString l 
    155152         return l' 
    156153 

  • src/Pugs/Bind.hs

    r15296 r15297  
    1 {-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -foverloaded-strings #-} 
     1{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-} 
    22 
    33{-| 

  • src/Pugs/CodeGen.hs

    r15296 r15297  
    4343    , ("Parse-YAML",  genParseYAML) 
    4444    , ("Parse-HsYAML",genParseHsYAML) 
    45     , ("Parse-Pretty",fmap (_VStr . (++"\n") . pretty) (asks envBody)) 
     45    , ("Parse-Pretty",fmap (VStr . (++"\n") . pretty) (asks envBody)) 
    4646--  , ("XML",         genXML) 
    4747    ] 
    … …  
    9191    rv <- runEvalIO env gen 
    9292    case rv of 
    93         VStr str    -> return (cast str) 
     93        VStr str    -> return str 
    9494        _           -> fail (show rv) 

  • src/Pugs/CodeGen/JSON.hs

    r15296 r15297  
    1111genJSON = do 
    1212    penv <- compile () :: Eval PIL_Environment 
    13     return . _VStr . unlines $ [showJSON penv] 
     13    return . VStr . unlines $ [showJSON penv] 

  • src/Pugs/CodeGen/PIL1.hs

    r15296 r15297  
    1010genPIL1 = do 
    1111    penv <- compile () 
    12     return . _VStr . unlines $ 
     12    return . VStr . unlines $ 
    1313        [ "PIL_Environment" 
    1414        , "    { pilMain = (" ++ show (pilMain penv) ++ ")" 

  • src/Pugs/CodeGen/PIL2.hs

    r15296 r15297  
    1717genPIL2 = do 
    1818    penv <- compile () 
    19     return . _VStr . unlines $ 
     19    return . VStr . unlines $ 
    2020        [ "PIL_Environment" 
    2121        , "    { pilMain = (" ++ show (pilMain penv) ++ ")" 
    … …  
    2727genPIL2Perl5 = do 
    2828    penv <- compile () :: Eval PIL_Environment 
    29