Changeset 3888

Timestamp:

05/26/05 02:20:34 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

5477

Message:

* fix double-evaluation bug for Perl 5 method invocation;

reported by Gruber.

Location:

src/Pugs

Files:

• Eval.hs (modified) (2 diffs)
• Prim.hs (modified) (3 diffs)

src/Pugs/Eval.hs

@@ -837 +837 @@
         [exp] | not (':' `elem` drop 2 name) -> do
             typ     <- evalExpType exp
-            if typ == mkType "Scalar::Perl5" then findPerl5Sub name else do
+            if typ == mkType "Scalar::Perl5" then runPerl5Sub name else do
             subs    <- findWithPkg (showType typ) name
             if isJust subs then return subs else findSub' name
@@ -844 +844 @@
             if isNothing sub then possiblyBuildMetaopVCode name else return sub
     where
-    findPerl5Sub name = do
-        sv      <- fromVal =<< fromVal =<< evalExp (head invs)
-        -- liftIO $ print ("Starting to handle", name, sv)
-        found   <- liftIO $ canPerl5 sv (tail name)
-        -- liftIO $ print ("Stage 1", found)
-        if found then runPerl5Sub name else do
-        sub     <- findSub' name
-        -- liftIO $ print ("Stage 2", sub)
-        if isJust sub then return sub else do
-        found   <- liftIO $ canPerl5 sv "AUTOLOAD"
-        -- liftIO $ print ("Stage 3", found)
-        if found then runPerl5Sub name else do
-        possiblyBuildMetaopVCode name
     runPerl5Sub name = do
-        subs    <- findWithPkg "Scalar::Perl5" "&AUTOLOAD"
-        writeVar "$*AUTOLOAD" (VStr $ tail name)
-        return subs
+        metaSub <- possiblyBuildMetaopVCode name
+        if isJust metaSub then return metaSub else do
+        return . Just $ mkPrim
+            { subName     = name
+            , subType     = SubPrim
+            , subAssoc    = "pre"
+            , subParams   = makeParams ["Object", "List"]
+            , subReturns  = mkType "Scalar::Perl5"
+            , subBody     = Prim $ \(inv:args:_) -> do
+                sv      <- fromVal inv
+                svs     <- fromVals args
+                found   <- liftIO $ canPerl5 sv (tail name) `mplus` canPerl5 sv "AUTOLOAD"
+                if not found then evalExp (App (Var name) [] (map (Val . PerlSV) (sv:svs))) else do
+                cxt     <- asks envContext
+                rv      <- liftIO $ callPerl5 (tail name) (sv:svs) (enumCxt cxt)
+                return $ PerlSV rv
+            }
     possiblyBuildMetaopVCode op' | "&prefix:[" `isPrefixOf` op', "]" `isSuffixOf` op' = do 
         -- Strip the trailing "]" from op

src/Pugs/Prim.hs

@@ -243 +243 @@
 op1 "eval_perl5" = \v -> do
     str <- fromVal v
+    cxt <- asks envContext
     tryIO undef $ do
-        sv <- evalPerl5 str
+        sv <- evalPerl5 str $ enumCxt cxt
         return $ PerlSV sv
 op1 "eval_haskell" = op1EvalHaskell
@@ -807 +808 @@
 op2 "say" = \x (VList ys) -> op1Print hPutStrLn (VList (x:ys))
 op2 "print" = \x (VList ys) -> op1Print hPutStr (VList (x:ys))
-op2 "Scalar::Perl5::AUTOLOAD" = \inv args -> do
-    meth <- readVar "$*AUTOLOAD"
-    str  <- fromVal meth
-    sv   <- fromVal inv
-    svs  <- fromVals args
-    rv   <- liftIO $ callPerl5 str (sv:svs)
-    return $ PerlSV rv
 op2 other = \_ _ -> fail ("Unimplemented binaryOp: " ++ other)
 
@@ -1404 +1398 @@
 \\n   Int       pre     arity   (Code)\
 \\n   Bool      pre     Thread::yield   (Thread)\
-\\n   Scalar::Perl5    pre     Scalar::Perl5::AUTOLOAD (Object: List)\
 \\n   List      pre     Pugs::Internals::runInteractiveCommand    (?Str=$_)\
 \\n   List      pre     Pugs::Internals::openFile    (?Str,?Str=$_)\