Changeset 3918

Show
Ignore:
Timestamp:
05/26/05 17:22:54 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
5482
Message:

* new pugsembed API with code!

Location:
src
Files:
6 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/AST/Internals.hs

    r3911 r3918  
    188188    fromVal $ VList vs 
    189189fromVal' (PerlSV sv) = do 
    190     rv <- liftIO $ svToAny sv 
    191     case rv of 
    192         Just v  -> fromVal v    -- it was a Val 
    193         _       -> fromSV sv    -- it was a SV 
     190    v <- liftIO $ svToVal sv 
     191    case v of 
     192        -- (PerlSV sv') -> fromSV sv'   -- it was a SV 
     193        Nothing     -> fromSV sv 
     194        Just val    -> fromVal val    -- it was a Val 
    194195fromVal' v = return $ vCast v 
    195196{-do 
    … …  
    320321instance Value VBool where 
    321322    castV = VBool 
    322     fromVal (PerlSV sv) = liftIO $ svToVBool sv 
    323     fromVal v = fromVal' v 
     323    fromSV sv = liftIO $ svToVBool sv 
    324324    doCast (VJunc j)   = juncToBool j 
    325325    doCast (VMatch m)  = matchOk m 
    … …  
    352352instance Value VInt where 
    353353    castV = VInt 
     354    fromSV sv = liftIO $ svToVInt sv 
    354355    doCast (VInt i)     = i 
    355356    doCast x            = truncate (vCast x :: VRat) 
    … …  
    357358instance Value VRat where 
    358359    castV = VRat 
     360    fromSV sv = liftIO $ svToVNum sv 
    359361    doCast (VInt i)     = i % 1 
    360362    doCast (VRat r)     = r 
    … …  
    373375instance Value VNum where 
    374376    castV = VNum 
     377    fromSV sv = liftIO $ svToVNum sv 
    375378    doCast VUndef       = 0 
    376379    doCast (VBool b)    = if b then 1 else 0 
    … …  
    399402instance Value VStr where 
    400403    castV = VStr 
     404    fromSV sv = liftIO $ svToVStr sv 
    401405    fromVal (VList l)   = return . unwords =<< mapM fromVal l 
    402     fromVal (PerlSV sv) = liftIO $ svToVStr sv 
     406    fromVal v@(PerlSV _) = fromVal' v 
    403407    fromVal v = do 
    404408        vt  <- evalValType v 
    … …  
    441445    fromVal (VStr str) = liftIO $ vstrToSV str 
    442446    fromVal (VInt int) = liftIO $ vintToSV int 
    443     fromVal v = liftIO $ anyToSV v 
     447    fromVal v = liftIO $ valToSV v 
    444448 
    445449showNum :: Show a => a -> String 
    … …  
    489493    doCast x            = castFail x 
    490494 
    491 instance Value Int   where 
     495instance Value Int where 
     496    fromSV sv = liftIO $ svToVInt sv 
    492497    doCast = intCast 
    493498    castV = VInt . fromIntegral 
    … …  
    499504 
    500505instance Value VScalar where 
     506    fromSV sv = return $ PerlSV sv 
    501507    fromVal (VRef r) = fromVal =<< readRef r 
    502508    fromVal v = return v 

  • src/Pugs/Embed/Perl5.hs

    r3911 r3918  
    2323svToVStr = constFail 
    2424 
     25svToVInt :: (Num a) => PerlSV -> IO a 
     26svToVInt = constFail 
     27 
     28svToVNum :: (Fractional a) => PerlSV -> IO a 
     29svToVNum = constFail 
     30 
    2531svToVBool :: PerlSV -> IO Bool 
    2632svToVBool = constFail 
    2733 
    28 svToAny :: PerlSV -> IO (Maybe a) 
    29 svToAny = constFail 
     34svToVal :: PerlSV -> IO (Maybe a) 
     35svToVal = constFail 
    3036 
    31 anyToSV :: a -> IO PerlSV 
    32 anyToSV = constFail 
     37valToSV :: a -> IO PerlSV 
     38valToSV = constFail 
    3339 
    3440vstrToSV :: String -> IO PerlSV 
    … …  
    4753 
    4854{-# INCLUDE <perl5.h> #-} 
     55{-# INCLUDE <pugsembed.h> #-} 
    4956 
    5057module Pugs.Embed.Perl5 where 
    … …  
    5562type PerlInterpreter = Ptr () 
    5663type PerlSV = Ptr () 
     64type PugsVal = Ptr () 
    5765 
    5866foreign import ccall "perl.h perl_alloc" 
    … …  
    7078foreign import ccall "perl5.h perl5_SvPV" 
    7179    perl5_SvPV :: PerlSV -> IO CString 
     80foreign import ccall "perl5.h perl5_SvIV" 
     81    perl5_SvIV :: PerlSV -> IO CInt 
     82foreign import ccall "perl5.h perl5_SvNV" 
     83    perl5_SvNV :: PerlSV -> IO CDouble 
    7284foreign import ccall "perl5.h perl5_SvTRUE" 
    7385    perl5_SvTRUE :: PerlSV -> IO Bool 
    74 foreign import ccall "perl5.h perl5_SvPtr" 
    75     perl5_SvPtr :: PerlSV -> IO (Ptr ()) 
    7686foreign import ccall "perl5.h perl5_newSVpv" 
    7787    perl5_newSVpv :: CString -> IO PerlSV 
    7888foreign import ccall "perl5.h perl5_newSViv" 
    7989    perl5_newSViv :: CInt -> IO PerlSV 
    80 foreign import ccall "perl5.h perl5_newSVptr" 
    81     perl5_newSVptr :: Ptr () -> IO PerlSV 
    8290foreign import ccall "perl5.h perl5_call" 
    8391    perl5_call :: CString -> CInt -> Ptr PerlSV -> CInt -> IO PerlSV 
    … …  
    8896foreign import ccall "perl5.h perl5_init" 
    8997    perl5_init :: CInt -> Ptr CString -> IO PerlInterpreter 
     98 
     99foreign import ccall "pugsembed.h pugs_SvToVal" 
     100    pugs_SvToVal :: PerlSV -> IO PugsVal 
     101foreign import ccall "pugsembed.h pugs_MkValRef" 
     102    pugs_MkValRef :: PugsVal -> IO PerlSV 
    90103 
    91104initPerl5 :: String -> IO PerlInterpreter 
    … …  
    98111svToVStr sv = peekCString =<< perl5_SvPV sv 
    99112 
     113svToVInt :: (Num a) => PerlSV -> IO a 
     114svToVInt sv = fmap fromIntegral $ perl5_SvIV sv 
     115 
     116svToVNum :: (Fractional a) => PerlSV -> IO a 
     117svToVNum sv = fmap realToFrac $ perl5_SvNV sv 
     118 
    100119svToVBool :: PerlSV -> IO Bool 
    101120svToVBool = perl5_SvTRUE 
    102121 
    103 anyToSV :: a -> IO PerlSV 
    104 anyToSV x = do 
    105     ptr <- fmap castStablePtrToPtr $ newStablePtr x 
    106     perl5_newSVptr ptr 
    107  
    108 svToAny :: PerlSV -> IO (Maybe a) 
    109 svToAny sv = do 
    110     ptr <- perl5_SvPtr sv 
     122svToVal :: PerlSV -> IO (Maybe a) 
     123svToVal sv = do 
     124    ptr <- pugs_SvToVal sv 
    111125    if ptr == nullPtr 
    112126        then return Nothing 
    113         else fmap Just . deRefStablePtr $ castPtrToStablePtr ptr 
     127        else fmap Just $ deRefStablePtr (castPtrToStablePtr ptr) 
     128 
     129valToSV :: a -> IO PerlSV 
     130valToSV x = do 
     131    ptr <- fmap castStablePtrToPtr $ newStablePtr x 
     132    pugs_MkValRef ptr 
    114133 
    115134vstrToSV :: String -> IO PerlSV 

  • src/perl5/perl5.c

    r3911 r3918  
    22#include <XSUB.h> 
    33#include "perlxsi.c" 
     4#include "pugsembed.c" 
    45 
    56/* Workaround for mapstart: the only op which needs a different ppaddr */ 
    … …  
    126127} 
    127128 
     129int 
     130perl5_SvIV ( SV *sv ) 
     131{ 
     132    return((int)SvIV(sv)); 
     133} 
     134 
     135double 
     136perl5_SvNV ( SV *sv ) 
     137{ 
     138    return((double)SvNV(sv)); 
     139} 
     140 
    128141bool 
    129142perl5_SvTRUE ( SV * sv ) 
    … …  
    134147} 
    135148 
    136 void * 
    137 perl5_SvPtr ( SV *sv ) 
    138 { 
    139     if (!sv_isa(sv, "pugs")) { 
    140         return NULL; 
    141     } 
    142     IV tmp = SvIV((SV*)SvRV(sv)); 
    143     return((void *)tmp); 
    144 } 
    145  
    146149SV * 
    147150perl5_newSVpv ( char * pv ) 
    … …  
    154157{ 
    155158    return(newSViv(iv)); 
    156 } 
    157  
    158 SV * 
    159 perl5_newSVptr ( void * ptr ) 
    160 { 
    161     SV *sv = newSV(0); 
    162     sv_setref_pv(sv, "pugs", ptr); 
    163     return(sv); 
    164159} 
    165160 

  • src/perl5/perl5.h

    r3901 r3918  
    55PerlInterpreter * perl5_init ( int argc, char **argv ); 
    66char * perl5_SvPV ( SV * sv ); 
     7int perl5_SvIV ( SV * sv ); 
     8double perl5_SvNV ( SV * sv ); 
    79bool perl5_SvTRUE ( SV * sv ); 
    8 void * perl5_SvPtr ( SV * sv ); 
    910SV * perl5_newSVpv ( char * pv ); 
    1011SV * perl5_newSViv ( int iv ); 
    11 SV * perl5_newSVptr ( void * ptr ); 
    1212SV * perl5_call(char *subname, int argc, SV** args, int cxt); 
    1313bool perl5_can(SV *inv, char *subname); 

  • src/perl5/pugsembed.c

    r3917 r3918  
    1818    return (sv); 
    1919} 
     20 
     21Val *pugs_Eval ( char *code ) { return NULL; } 
     22 
     23Val *pugs_Apply ( Val *sub, Val *inv, Val **args ) { return NULL; } 
     24 
     25Val *pugs_IvToVal ( IV iv ) { return NULL; } 
     26 
     27Val *pugs_NvToVal ( NV iv ) { return NULL; } 
     28 
     29Val *pugs_PvToVal ( char *pv ) { return NULL; } 
     30 
     31Val *pugs_MkSvRef  ( SV *sv ) { return NULL; } 
     32 
     33SV  *pugs_ValToSv ( Val *val ) { return NULL; } 

  • src/perl5/pugsembed.h

    r3917 r3918  
    11#include "perl5.h" 
     2#include <HsFFI.h> 
    23 
    3 typedef void Val; 
     4#ifndef PugsValDefined 
     5#define PugsValDefined 1 
     6/* #define PUGS_EXTERN extern */ 
     7#define PUGS_EXTERN   
     8typedef HsStablePtr Val; 
     9#endif 
    410 
    5 extern Val *pugs_Eval ( char *code ); 
    6 extern Val *pugs_Apply ( Val *sub, Val *inv, Val **args ); 
     11PUGS_EXTERN Val *pugs_Eval ( char *code ); 
     12PUGS_EXTERN Val *pugs_Apply ( Val *sub, Val *inv, Val **args ); 
    713 
    8 extern Val *pugs_IvToVal ( IV iv ); 
    9 extern Val *pugs_NvToVal ( NV iv ); 
    10 extern Val *pugs_PvToVal ( char *pv ); 
     14PUGS_EXTERN Val *pugs_IvToVal ( IV iv ); 
     15PUGS_EXTERN Val *pugs_NvToVal ( NV iv ); 
     16PUGS_EXTERN Val *pugs_PvToVal ( char *pv ); 
    1117 
    12 extern Val *pugs_MkSvRef  ( SV *sv ); 
    13 extern SV  *pugs_ValToSv ( Val *val ); 
     18PUGS_EXTERN Val *pugs_MkSvRef  ( SV *sv ); 
     19PUGS_EXTERN SV  *pugs_ValToSv ( Val *val ); 
    1420 
    1521Val *pugs_SvToVal ( SV *sv );