Changeset 22338

Show
Ignore:
Timestamp:
09/24/08 18:49:40 (2 months ago)
Author:
pmurias
Message:

[pugs] evaling code in the embedded smop works

Files:
4 modified

Legend:

Unmodified
Added
Removed

  • Pugs.cabal.in

    r22321 r22338  
    180180 
    181181    if flag(SMOP) 
    182         extra-Libraries: smop 
     182        extra-libraries: smop 
     183        extra-lib-dirs: v6/smop/build 
    183184        cpp-options: -DPUGS_HAVE_SMOP=1 
    184185 

  • src/M0ld/AST.hs

    r22334 r22338  
    99    deriving (Show,Eq,Ord) 
    1010data Argument = Pos Register | Named Register Register 
    11  
    12 data Mold = Mold [Stmt] 
    13     deriving Show 

  • src/Pugs/Embed/M0ld.hs

    r22336 r22338  
    77import Debug.Trace 
    88import M0ld 
     9import M0ld.AST 
     10import M0ld.Parser 
    911 
    1012foreign import ccall "smop.h smop_init" 
    … …  
    4042foreign import ccall "smop_mold.h SMOP__Mold_create" 
    4143    c_SMOP__Mold_create :: Int -> Ptr SMOP__Object -> Int -> Ptr Int -> IO SMOP__Object 
    42 mold regs constants opcodes = do 
    43     constants_ <- mapM smopify constants 
    44     withArray0 nullPtr constants_ (\c_constants -> withArray opcodes (\c_opcodes -> c_SMOP__Mold_create regs c_constants (length opcodes) c_opcodes)) 
    4544 
    4645 
    4746foreign import ccall "smop_haskell_ffi.h &smop_release_with_global" 
    4847    p_release :: FunPtr (Ptr a -> IO ()) 
     48 
     49foreign import ccall "smop_haskell_ffi.h smop_get_cvar" 
     50    smop_get_cvar :: CString -> IO SMOP__Object 
     51 
     52get_cvar str = do 
     53    obj <- withCString str smop_get_cvar 
     54    auto_release obj 
    4955 
    5056auto_release :: SMOP__Object -> IO Object 
    … …  
    5662      get_SMOP__S1P__RootNamespace :: IO SMOP__Object 
    5763 
    58 rootnamespace = get_SMOP__S1P__RootNamespace 
     64rootnamespace = do 
     65    root <- get_SMOP__S1P__RootNamespace 
     66    auto_release root 
    5967 
    6068class Smopify a where 
    … …  
    7179    smopify a = return (idconst_ptr a) 
    7280 
     81mold :: (Smopify a) => Int -> [a] -> [Int] -> IO Object 
     82mold regs constants opcodes = do 
     83    constants_ <- mapM smopify constants 
     84    new_mold <- withArray0 nullPtr constants_ (\c_constants -> withArray opcodes (\c_opcodes -> c_SMOP__Mold_create regs c_constants (length opcodes) c_opcodes)) 
     85    auto_release new_mold 
     86 
    7387call inv ident pos named = do 
    7488    inv_ <- smopify inv 
    … …  
    8397none = [] 
    8498 
     99metachars :: [Char] -> [Char] 
     100metachars str = case str of 
     101    [] -> "" 
     102    '\\':'n':rest -> '\n' : (metachars rest) 
     103    '\\':other:rest -> other : (metachars rest) 
     104    letter:rest -> letter : (metachars rest) 
     105 
     106createConstant :: Value -> IO Object 
     107createConstant constant = case constant of 
     108    Var var -> get_cvar var 
     109    IntegerConstant int -> error "integer constant" 
     110    StringConstant str -> return $ idconst $ metachars $ str 
     111    SubMold stmts -> createM0ld stmts 
     112 
     113compileM0ld = createM0ld . parseM0ld 
     114 
     115createM0ld ast = do 
     116    let labelsMap = mapLabels ast 
     117        regMap    = mapRegisters ast 
     118        freeRegs  = countRegister ast 
     119        bytecode  = emit ast regMap labelsMap 
     120    constants <- mapM createConstant [c | Decl reg c <- filter (not . isReg) ast] 
     121    mold freeRegs constants bytecode 
    85122evalM0ld code = do 
    86123    smop_init 
    87124    root <- rootnamespace 
    88125 
    89     c_smop_reference interpreter interpreter 
    90  
    91     c_smop_reference interpreter root 
    92126    out_scalar <- call root "postcircumfix:{ }" ["$*OUT"] none 
    93127    out <- call out_scalar "FETCH" none none 
    94128 
    95     c_smop_reference interpreter root 
    96129    mold_frame_scalar <- call root "postcircumfix:{ }" ["::MoldFrame"] none 
    97130    mold_frame <- call mold_frame_scalar "FETCH" none none 
    98131 
    99     test_mold <- mold 8 [out,idconst "print",idconst "embedding from pugs\n"] [1,3,0,1,1,2,0,0] 
     132    test_mold <- compileM0ld code 
    100133    test_frame <- call mold_frame "new" [test_mold] none 
    101134 

  • v6/smop/src/smop_haskell_ffi.c

    r22336 r22338  
    2525  return SMOP__S1P__RootNamespace; 
    2626} 
     27SMOP__Object* smop_get_cvar(char* var) { 
     28  if (strcmp(var,"SMOP__S1P__LexicalScope") == 0) return SMOP__S1P__LexicalScope; 
     29  else if (strcmp(var,"SMOP__S1P__RootNamespace") == 0) return SMOP__S1P__RootNamespace; 
     30  printf("unable to fetch %s\n"); 
     31  return SMOP__NATIVE__bool_false; 
     32}