Changeset 3925

Timestamp:

05/27/05 00:14:36 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

5515

Message:

* Pugs's eval/apply exported to C space.

Location:

src

Files:

• Pugs/Embed/Perl5.hs (modified) (1 diff)
• Pugs/Run/Perl5.hs (modified) (3 diffs)
• perl5/perl5.c (modified) (1 diff)
• perl5/perl5.h (modified) (1 diff)

src/Pugs/Embed/Perl5.hs

@@ -96 +96 @@
 foreign import ccall "perl5.h perl5_newSVnv"
     perl5_newSVnv :: CDouble -> IO PerlSV
+foreign import ccall "perl5.h perl5_get_sv"
+    perl5_get_sv :: CString -> IO PerlSV
 foreign import ccall "perl5.h perl5_call"
     perl5_call :: CString -> CInt -> Ptr PerlSV -> CInt -> IO PerlSV

src/Pugs/Run/Perl5.hs

@@ -7 +7 @@
 import Pugs.Internals
 import Pugs.AST
+import Pugs.Prim.Eval
 import Pugs.Embed.Perl5
 import Foreign
 import Foreign.C.Types
 import Foreign.C.String
+import Foreign.Marshal.Array
+
+foreign export ccall "pugs_Eval"
+    pugs_eval :: CString -> IO PugsVal
+
+foreign export ccall "pugs_Apply"
+    pugs_apply :: PugsVal -> PugsVal -> Ptr PugsVal -> IO PugsVal
 
 foreign export ccall "pugs_ValToSv"
@@ -27 +35 @@
     pvToVal :: CString -> IO PugsVal
 
+askPerl5Env :: IO Env
+askPerl5Env = do
+    sv  <- withCString "pugs::env" perl5_get_sv 
+    val <- svToVal sv
+    case val of
+        VControl (ControlEnv env)   -> return env
+        _                           -> fail "cannot fetch $pugs::env"
+
+pugs_eval :: CString -> IO PugsVal
+pugs_eval cstr = do
+    str <- peekCString cstr
+    env <- askPerl5Env
+    val <- runEvalIO env $ opEval Nothing "<eval>" str
+    mkVal val
+
+pugs_apply :: PugsVal -> PugsVal -> Ptr PugsVal -> IO PugsVal
+pugs_apply subPtr invPtr argsPtr = do
+    env     <- askPerl5Env
+    sub     <- deVal subPtr
+    inv     <- deValMaybe invPtr
+    args    <- mapM deVal =<< peekArray0 nullPtr argsPtr
+    let subExp = case sub of
+            VStr name   -> Var name
+            _           -> Val sub
+    val <- runEvalIO env $ evalExp (App subExp (fmap Val inv) (map Val args))
+    mkVal val
+
 mkVal :: Val -> IO PugsVal
 mkVal val = fmap castStablePtrToPtr $ newStablePtr val
@@ -32 +67 @@
 deVal :: PugsVal -> IO Val
 deVal ptr = deRefStablePtr (castPtrToStablePtr ptr)
+
+deValMaybe :: PugsVal -> IO (Maybe Val)
+deValMaybe ptr | ptr == nullPtr = return Nothing
+deValMaybe ptr = fmap Just (deVal ptr)
 
 valToSv :: PugsVal -> IO PerlSV

src/perl5/perl5.c

@@ -196 +196 @@
 
 SV *
+perl5_get_sv(const char *name)
+{
+    return (get_sv(name, 1));
+}
+
+SV *
 perl5_eval(char *code, SV *env, int cxt)
 {

src/perl5/perl5.h

@@ -14 +14 @@
 bool perl5_can(SV *inv, char *subname);
 SV * perl5_eval(char *code, SV *env, int cxt);
+SV * perl5_get_sv ( const char *name );