Changeset 3956

Timestamp:

05/27/05 04:31:40 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

5515

Message:

* new callconv -- pugs apply now takes Cxt

Location:

src

Files:

• Pugs/Run/Perl5.hs (modified) (4 diffs)
• Pugs/Types.hs (modified) (1 diff)
• perl5/perl5.c (modified) (1 diff)
• perl5/pugsembed.c (modified) (1 diff)
• perl5/pugsembed.h (modified) (1 diff)

src/Pugs/Run/Perl5.hs

@@ -9 +9 @@
 import Pugs.Prim.Eval
 import Pugs.Embed.Perl5
+import Pugs.Types
 import Foreign
 import Foreign.C.Types
@@ -18 +19 @@
 
 foreign export ccall "pugs_Apply"
-    pugs_apply :: PugsVal -> PugsVal -> Ptr PugsVal -> IO PerlSV
+    pugs_apply :: PugsVal -> PugsVal -> Ptr PugsVal -> CInt -> IO PerlSV
 
 foreign export ccall "pugs_ValToSv"
@@ -60 +61 @@
     mkVal val
 
-pugs_apply :: PugsVal -> PugsVal -> Ptr PugsVal -> IO PerlSV
-pugs_apply subPtr invPtr argsPtr = do
+pugs_apply :: PugsVal -> PugsVal -> Ptr PugsVal -> CInt -> IO PerlSV
+pugs_apply subPtr invPtr argsPtr cxt = do
     -- print "DEREF #0"
     env     <- askPerl5Env
@@ -74 +75 @@
             VStr name   -> Var name
             _           -> Val sub
-    val <- runEvalIO env $ evalExp (App subExp (fmap Val inv) (map Val args))
+    val <- runEvalIO env $
+        evalExp (Cxt (cxtEnum cxt) $ App subExp (fmap Val inv) (map Val args))
     case val of
         PerlSV sv   -> return sv

src/Pugs/Types.hs

@@ -81 +81 @@
 enumCxt (CxtSlurpy _) = 1
 
+cxtEnum :: (Show a, Num a) => a -> Cxt
+cxtEnum 128 = CxtVoid
+cxtEnum 0   = cxtItemAny
+cxtEnum 1   = cxtSlurpyAny
+cxtEnum n   = error ("Invalid cxt: " ++ show n)
+
 -- |Make a type value representing the type with the specified name.
 -- Recognises conjunctive (&) and disjunctive (|) types.

src/perl5/perl5.c

@@ -52 +52 @@
     stack[i-2] = NULL;
     
-    ST(0) = pugs_Apply(val, inv, stack);
+    ST(0) = pugs_Apply(val, inv, stack, GIMME_V);
     sv_dump (ret);
     free (stack);

src/perl5/pugsembed.c

@@ -23 +23 @@
     isa[0] = pugs_PvToVal("Code");
     isa[1] = NULL;
-    if (SvTRUE(pugs_Apply(pugs_PvToVal("&isa"), val, isa))) {
+    if (SvTRUE(pugs_Apply(pugs_PvToVal("&isa"), val, isa, G_SCALAR))) {
         if (__init) {
             stack[0] = sv;

src/perl5/pugsembed.h

@@ -8 +8 @@
 
 extern Val *pugs_Eval ( char *code );
-extern SV *pugs_Apply ( Val *sub, Val *inv, Val **args );
+extern SV *pugs_Apply ( Val *sub, Val *inv, Val **args, int cxt );
 
 extern Val *pugs_IvToVal ( IV iv );