diff --git a/hslua.cabal b/hslua.cabal --- a/hslua.cabal +++ b/hslua.cabal @@ -1,5 +1,5 @@ Name: hslua -Version: 0.1 +Version: 0.2 Stability: alpha Exposed-modules: Scripting.Lua License: BSD3 @@ -7,11 +7,10 @@ Copyright: 2007-2007, Gracjan Polak Author: Gracjan Polak Maintainer: Gracjan Polak -Homepage: http://home.agh.edu.pl/~gpolak/hslua Synopsis: A Lua language interpreter embedding in Haskell Description: The Scripting.Lua module is a wrapper of Lua language interpreter - as described in http://www.lua.org/. + as described in www.lua.org. . The package is standalone: full Lua interpreter is distributed in this package as well. diff --git a/src/HsLuaMain.hs b/src/HsLuaMain.hs deleted file mode 100644 --- a/src/HsLuaMain.hs +++ /dev/null @@ -1,46 +0,0 @@ - -{-# OPTIONS_GHC -fffi -fglasgow-exts #-} -module Main where -import qualified Scripting.Lua as Lua -import Foreign.C.Types -import Foreign.Ptr - -foreign export ccall hs_lua_c_func :: Lua.LuaState -> IO CInt -foreign import ccall "&hs_lua_c_func" hs_lua_c_func_addr :: FunPtr Lua.LuaCFunction - -hs_lua_c_func l = do - putStrLn "from haskell" - return 0 - - -main = do - l <- Lua.newstate - Lua.openlibs l - Lua.getglobal l "print" - Lua.pushstring l "from print" - putStrLn "NEXT: from print" - Lua.call l 1 0 - Lua.register l "kill" hs_lua_c_func_addr - Lua.getglobal l "kill" - putStrLn "NEXT: from haskell" - Lua.call l 0 0 - c <- Lua.load l "print \"preparation\"; function f () print \"in lua def fun\"; end" "inline code" - putStrLn "NEXT: result 0" - putStrLn ("result " ++ show c) - putStrLn "NEXT: preparation" - Lua.call l 0 Lua.multret - Lua.getglobal l "f" - putStrLn "NEXT: in lua def fun" - Lua.call l 0 0 - Lua.getglobal l "print" - Lua.push l (42::Int) - putStrLn "NEXT: 42" - Lua.call l 1 0 - Lua.push l (42::Int) - putStrLn "NEXT: number 42" - Just (x::Int) <- Lua.peek l (-1) - putStrLn ("number " ++ show x) - putStrLn "NEXT: string 42" - Just (x::String) <- Lua.peek l (-1) - putStrLn ("string " ++ x) - Lua.close l diff --git a/src/Scripting/Lua.hs b/src/Scripting/Lua.hs --- a/src/Scripting/Lua.hs +++ b/src/Scripting/Lua.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances #-} +{-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances, FlexibleInstances #-} -- | -- Module : Scripting.Lua -- Copyright : (c) Gracjan Polak 2007 @@ -160,6 +160,7 @@ loadfile, loadstring, newmetatable, + argerror, -- * Haskell extensions StackValue(..), @@ -169,7 +170,8 @@ newcfunction, freecfunction, luaimport, - pushhsfunction + pushhsfunction, + registerhsfunction ) where import Prelude hiding (error,concat) @@ -360,6 +362,7 @@ foreign import ccall "lualib.h luaL_openlibs" c_luaL_openlibs :: LuaState -> IO () foreign import ccall "lauxlib.h luaL_newstate" c_luaL_newstate :: IO LuaState foreign import ccall "lauxlib.h luaL_newmetatable" c_luaL_newmetatable :: LuaState -> Ptr CChar -> IO CInt +foreign import ccall "lauxlib.h luaL_argerror" c_luaL_argerror :: LuaState -> CInt -> Ptr CChar -> IO CInt foreign import ccall "ntrljmp.h lua_neutralize_longjmp" c_lua_neutralize_longjmp :: LuaState -> IO CInt foreign import ccall "ntrljmp.h &lua_neutralize_longjmp" c_lua_neutralize_longjmp_addr :: FunPtr (LuaState -> IO CInt) @@ -779,10 +782,23 @@ pushcclosure l f 0 setglobal l n +-- | See @luaL_newmetatable@ in Lua Reference Manual. newmetatable :: LuaState -> String -> IO Int newmetatable l s = withCString s $ \s -> liftM fromIntegral (c_luaL_newmetatable l s) +-- | See @luaL_argerror@ in Lua Reference Manual. Contrary to the +-- manual, Haskell function does return with value less than zero. +argerror :: LuaState -> Int -> String -> IO CInt +argerror l n msg = withCString msg $ \msg -> do + let doit l = c_luaL_argerror l (fromIntegral n) msg + f <- mkWrapper doit + c_lua_cpcall l f nullPtr + freeHaskellFunPtr f + -- here we should have error message string on top of the stack + return (-1) + + -- | A value that can be pushed and poped from the Lua stack. -- All instances are natural, except following: -- @@ -900,14 +916,14 @@ class LuaImport a where luaimport' :: Int -> a -> LuaCFunction - luaimportargerror :: String -> a -> LuaCFunction + luaimportargerror :: Int -> String -> a -> LuaCFunction instance (StackValue a) => LuaImport (IO a) where - luaimportargerror msg x l = push l msg >> return (-1) + luaimportargerror n msg x l = argerror l n msg luaimport' narg x l = x >>= push l >> return 1 instance (StackValue a,LuaImport b) => LuaImport (a -> b) where - luaimportargerror msg x l = luaimportargerror msg (x undefined) l + luaimportargerror n msg x l = luaimportargerror n msg (x undefined) l {- - FIXME: Cannot catch this exception here, because we are called from C, - and error propagation, stack unwinding, etc does not work. @@ -921,9 +937,7 @@ t <- ltype l narg exp <- typename l (valuetype (fromJust arg)) got <- typename l t - luaimportargerror ("Incorrect argument #" ++ show narg ++ - " expected " ++ exp ++ - " got " ++ got) (x undefined) l + luaimportargerror narg (exp ++ " expected, got " ++ got) (x undefined) l foreign import ccall "wrapper" mkWrapper :: LuaCFunction -> IO (FunPtr LuaCFunction) @@ -1051,3 +1065,7 @@ setfield l (-2) "__call" setmetatable l (-2) return () + +-- | Imports a Haskell function and registers it at global name. +registerhsfunction :: LuaImport a => LuaState -> String -> a -> IO () +registerhsfunction l n f = pushhsfunction l f >> setglobal l n diff --git a/src/lua.c b/src/lua.c deleted file mode 100644 --- a/src/lua.c +++ /dev/null @@ -1,390 +0,0 @@ -/* -** $Id: lua.c,v 1.160 2006/06/02 15:34:00 roberto Exp $ -** Lua stand-alone interpreter -** See Copyright Notice in lua.h -*/ - - -#include -#include -#include -#include - -#define lua_c - -#include "lua.h" - -#include "lauxlib.h" -#include "lualib.h" - - - -static lua_State *globalL = NULL; - -static const char *progname = LUA_PROGNAME; - - - -static void lstop (lua_State *L, lua_Debug *ar) { - (void)ar; /* unused arg. */ - lua_sethook(L, NULL, 0, 0); - luaL_error(L, "interrupted!"); -} - - -static void laction (int i) { - signal(i, SIG_DFL); /* if another SIGINT happens before lstop, - terminate process (default action) */ - lua_sethook(globalL, lstop, LUA_MASKCALL | LUA_MASKRET | LUA_MASKCOUNT, 1); -} - - -static void print_usage (void) { - fprintf(stderr, - "usage: %s [options] [script [args]].\n" - "Available options are:\n" - " -e stat execute string " LUA_QL("stat") "\n" - " -l name require library " LUA_QL("name") "\n" - " -i enter interactive mode after executing " LUA_QL("script") "\n" - " -v show version information\n" - " -- stop handling options\n" - " - execute stdin and stop handling options\n" - , - progname); - fflush(stderr); -} - - -static void l_message (const char *pname, const char *msg) { - if (pname) fprintf(stderr, "%s: ", pname); - fprintf(stderr, "%s\n", msg); - fflush(stderr); -} - - -static int report (lua_State *L, int status) { - if (status && !lua_isnil(L, -1)) { - const char *msg = lua_tostring(L, -1); - if (msg == NULL) msg = "(error object is not a string)"; - l_message(progname, msg); - lua_pop(L, 1); - } - return status; -} - - -static int traceback (lua_State *L) { - lua_getfield(L, LUA_GLOBALSINDEX, "debug"); - if (!lua_istable(L, -1)) { - lua_pop(L, 1); - return 1; - } - lua_getfield(L, -1, "traceback"); - if (!lua_isfunction(L, -1)) { - lua_pop(L, 2); - return 1; - } - lua_pushvalue(L, 1); /* pass error message */ - lua_pushinteger(L, 2); /* skip this function and traceback */ - lua_call(L, 2, 1); /* call debug.traceback */ - return 1; -} - - -static int docall (lua_State *L, int narg, int clear) { - int status; - int base = lua_gettop(L) - narg; /* function index */ - lua_pushcfunction(L, traceback); /* push traceback function */ - lua_insert(L, base); /* put it under chunk and args */ - signal(SIGINT, laction); - status = lua_pcall(L, narg, (clear ? 0 : LUA_MULTRET), base); - signal(SIGINT, SIG_DFL); - lua_remove(L, base); /* remove traceback function */ - /* force a complete garbage collection in case of errors */ - if (status != 0) lua_gc(L, LUA_GCCOLLECT, 0); - return status; -} - - -static void print_version (void) { - l_message(NULL, LUA_RELEASE " " LUA_COPYRIGHT); -} - - -static int getargs (lua_State *L, char **argv, int n) { - int narg; - int i; - int argc = 0; - while (argv[argc]) argc++; /* count total number of arguments */ - narg = argc - (n + 1); /* number of arguments to the script */ - luaL_checkstack(L, narg + 3, "too many arguments to script"); - for (i=n+1; i < argc; i++) - lua_pushstring(L, argv[i]); - lua_createtable(L, narg, n + 1); - for (i=0; i < argc; i++) { - lua_pushstring(L, argv[i]); - lua_rawseti(L, -2, i - n); - } - return narg; -} - - -static int dofile (lua_State *L, const char *name) { - int status = luaL_loadfile(L, name) || docall(L, 0, 1); - return report(L, status); -} - - -static int dostring (lua_State *L, const char *s, const char *name) { - int status = luaL_loadbuffer(L, s, strlen(s), name) || docall(L, 0, 1); - return report(L, status); -} - - -static int dolibrary (lua_State *L, const char *name) { - lua_getglobal(L, "require"); - lua_pushstring(L, name); - return report(L, lua_pcall(L, 1, 0, 0)); -} - - -static const char *get_prompt (lua_State *L, int firstline) { - const char *p; - lua_getfield(L, LUA_GLOBALSINDEX, firstline ? "_PROMPT" : "_PROMPT2"); - p = lua_tostring(L, -1); - if (p == NULL) p = (firstline ? LUA_PROMPT : LUA_PROMPT2); - lua_pop(L, 1); /* remove global */ - return p; -} - - -static int incomplete (lua_State *L, int status) { - if (status == LUA_ERRSYNTAX) { - size_t lmsg; - const char *msg = lua_tolstring(L, -1, &lmsg); - const char *tp = msg + lmsg - (sizeof(LUA_QL("")) - 1); - if (strstr(msg, LUA_QL("")) == tp) { - lua_pop(L, 1); - return 1; - } - } - return 0; /* else... */ -} - - -static int pushline (lua_State *L, int firstline) { - char buffer[LUA_MAXINPUT]; - char *b = buffer; - size_t l; - const char *prmt = get_prompt(L, firstline); - if (lua_readline(L, b, prmt) == 0) - return 0; /* no input */ - l = strlen(b); - if (l > 0 && b[l-1] == '\n') /* line ends with newline? */ - b[l-1] = '\0'; /* remove it */ - if (firstline && b[0] == '=') /* first line starts with `=' ? */ - lua_pushfstring(L, "return %s", b+1); /* change it to `return' */ - else - lua_pushstring(L, b); - lua_freeline(L, b); - return 1; -} - - -static int loadline (lua_State *L) { - int status; - lua_settop(L, 0); - if (!pushline(L, 1)) - return -1; /* no input */ - for (;;) { /* repeat until gets a complete line */ - status = luaL_loadbuffer(L, lua_tostring(L, 1), lua_strlen(L, 1), "=stdin"); - if (!incomplete(L, status)) break; /* cannot try to add lines? */ - if (!pushline(L, 0)) /* no more input? */ - return -1; - lua_pushliteral(L, "\n"); /* add a new line... */ - lua_insert(L, -2); /* ...between the two lines */ - lua_concat(L, 3); /* join them */ - } - lua_saveline(L, 1); - lua_remove(L, 1); /* remove line */ - return status; -} - - -static void dotty (lua_State *L) { - int status; - const char *oldprogname = progname; - progname = NULL; - while ((status = loadline(L)) != -1) { - if (status == 0) status = docall(L, 0, 0); - report(L, status); - if (status == 0 && lua_gettop(L) > 0) { /* any result to print? */ - lua_getglobal(L, "print"); - lua_insert(L, 1); - if (lua_pcall(L, lua_gettop(L)-1, 0, 0) != 0) - l_message(progname, lua_pushfstring(L, - "error calling " LUA_QL("print") " (%s)", - lua_tostring(L, -1))); - } - } - lua_settop(L, 0); /* clear stack */ - fputs("\n", stdout); - fflush(stdout); - progname = oldprogname; -} - - -static int handle_script (lua_State *L, char **argv, int n) { - int status; - const char *fname; - int narg = getargs(L, argv, n); /* collect arguments */ - lua_setglobal(L, "arg"); - fname = argv[n]; - if (strcmp(fname, "-") == 0 && strcmp(argv[n-1], "--") != 0) - fname = NULL; /* stdin */ - status = luaL_loadfile(L, fname); - lua_insert(L, -(narg+1)); - if (status == 0) - status = docall(L, narg, 0); - else - lua_pop(L, narg); - return report(L, status); -} - - -/* check that argument has no extra characters at the end */ -#define notail(x) {if ((x)[2] != '\0') return -1;} - - -static int collectargs (char **argv, int *pi, int *pv, int *pe) { - int i; - for (i = 1; argv[i] != NULL; i++) { - if (argv[i][0] != '-') /* not an option? */ - return i; - switch (argv[i][1]) { /* option */ - case '-': - notail(argv[i]); - return (argv[i+1] != NULL ? i+1 : 0); - case '\0': - return i; - case 'i': - notail(argv[i]); - *pi = 1; /* go through */ - case 'v': - notail(argv[i]); - *pv = 1; - break; - case 'e': - *pe = 1; /* go through */ - case 'l': - if (argv[i][2] == '\0') { - i++; - if (argv[i] == NULL) return -1; - } - break; - default: return -1; /* invalid option */ - } - } - return 0; -} - - -static int runargs (lua_State *L, char **argv, int n) { - int i; - for (i = 1; i < n; i++) { - if (argv[i] == NULL) continue; - lua_assert(argv[i][0] == '-'); - switch (argv[i][1]) { /* option */ - case 'e': { - const char *chunk = argv[i] + 2; - if (*chunk == '\0') chunk = argv[++i]; - lua_assert(chunk != NULL); - if (dostring(L, chunk, "=(command line)") != 0) - return 1; - break; - } - case 'l': { - const char *filename = argv[i] + 2; - if (*filename == '\0') filename = argv[++i]; - lua_assert(filename != NULL); - if (dolibrary(L, filename)) - return 1; /* stop if file fails */ - break; - } - default: break; - } - } - return 0; -} - - -static int handle_luainit (lua_State *L) { - const char *init = getenv(LUA_INIT); - if (init == NULL) return 0; /* status OK */ - else if (init[0] == '@') - return dofile(L, init+1); - else - return dostring(L, init, "=" LUA_INIT); -} - - -struct Smain { - int argc; - char **argv; - int status; -}; - - -static int pmain (lua_State *L) { - struct Smain *s = (struct Smain *)lua_touserdata(L, 1); - char **argv = s->argv; - int script; - int has_i = 0, has_v = 0, has_e = 0; - globalL = L; - if (argv[0] && argv[0][0]) progname = argv[0]; - lua_gc(L, LUA_GCSTOP, 0); /* stop collector during initialization */ - luaL_openlibs(L); /* open libraries */ - lua_gc(L, LUA_GCRESTART, 0); - s->status = handle_luainit(L); - if (s->status != 0) return 0; - script = collectargs(argv, &has_i, &has_v, &has_e); - if (script < 0) { /* invalid args? */ - print_usage(); - s->status = 1; - return 0; - } - if (has_v) print_version(); - s->status = runargs(L, argv, (script > 0) ? script : s->argc); - if (s->status != 0) return 0; - if (script) - s->status = handle_script(L, argv, script); - if (s->status != 0) return 0; - if (has_i) - dotty(L); - else if (script == 0 && !has_e && !has_v) { - if (lua_stdin_is_tty()) { - print_version(); - dotty(L); - } - else dofile(L, NULL); /* executes stdin as a file */ - } - return 0; -} - - -int main (int argc, char **argv) { - int status; - struct Smain s; - lua_State *L = lua_open(); /* create state */ - if (L == NULL) { - l_message(argv[0], "cannot create state: not enough memory"); - return EXIT_FAILURE; - } - s.argc = argc; - s.argv = argv; - status = lua_cpcall(L, &pmain, &s); - report(L, status); - lua_close(L); - return (status || s.status) ? EXIT_FAILURE : EXIT_SUCCESS; -} - diff --git a/src/luac.c b/src/luac.c deleted file mode 100644 --- a/src/luac.c +++ /dev/null @@ -1,200 +0,0 @@ -/* -** $Id: luac.c,v 1.54 2006/06/02 17:37:11 lhf Exp $ -** Lua compiler (saves bytecodes to files; also list bytecodes) -** See Copyright Notice in lua.h -*/ - -#include -#include -#include -#include - -#define luac_c -#define LUA_CORE - -#include "lua.h" -#include "lauxlib.h" - -#include "ldo.h" -#include "lfunc.h" -#include "lmem.h" -#include "lobject.h" -#include "lopcodes.h" -#include "lstring.h" -#include "lundump.h" - -#define PROGNAME "luac" /* default program name */ -#define OUTPUT PROGNAME ".out" /* default output file */ - -static int listing=0; /* list bytecodes? */ -static int dumping=1; /* dump bytecodes? */ -static int stripping=0; /* strip debug information? */ -static char Output[]={ OUTPUT }; /* default output file name */ -static const char* output=Output; /* actual output file name */ -static const char* progname=PROGNAME; /* actual program name */ - -static void fatal(const char* message) -{ - fprintf(stderr,"%s: %s\n",progname,message); - exit(EXIT_FAILURE); -} - -static void cannot(const char* what) -{ - fprintf(stderr,"%s: cannot %s %s: %s\n",progname,what,output,strerror(errno)); - exit(EXIT_FAILURE); -} - -static void usage(const char* message) -{ - if (*message=='-') - fprintf(stderr,"%s: unrecognized option " LUA_QS "\n",progname,message); - else - fprintf(stderr,"%s: %s\n",progname,message); - fprintf(stderr, - "usage: %s [options] [filenames].\n" - "Available options are:\n" - " - process stdin\n" - " -l list\n" - " -o name output to file " LUA_QL("name") " (default is \"%s\")\n" - " -p parse only\n" - " -s strip debug information\n" - " -v show version information\n" - " -- stop handling options\n", - progname,Output); - exit(EXIT_FAILURE); -} - -#define IS(s) (strcmp(argv[i],s)==0) - -static int doargs(int argc, char* argv[]) -{ - int i; - int version=0; - if (argv[0]!=NULL && *argv[0]!=0) progname=argv[0]; - for (i=1; itop+(i))->l.p) - -static const Proto* combine(lua_State* L, int n) -{ - if (n==1) - return toproto(L,-1); - else - { - int i,pc; - Proto* f=luaF_newproto(L); - setptvalue2s(L,L->top,f); incr_top(L); - f->source=luaS_newliteral(L,"=(" PROGNAME ")"); - f->maxstacksize=1; - pc=2*n+1; - f->code=luaM_newvector(L,pc,Instruction); - f->sizecode=pc; - f->p=luaM_newvector(L,n,Proto*); - f->sizep=n; - pc=0; - for (i=0; ip[i]=toproto(L,i-n-1); - f->code[pc++]=CREATE_ABx(OP_CLOSURE,0,i); - f->code[pc++]=CREATE_ABC(OP_CALL,0,1,1); - } - f->code[pc++]=CREATE_ABC(OP_RETURN,0,1,0); - return f; - } -} - -static int writer(lua_State* L, const void* p, size_t size, void* u) -{ - UNUSED(L); - return (fwrite(p,size,1,(FILE*)u)!=1) && (size!=0); -} - -struct Smain { - int argc; - char** argv; -}; - -static int pmain(lua_State* L) -{ - struct Smain* s = (struct Smain*)lua_touserdata(L, 1); - int argc=s->argc; - char** argv=s->argv; - const Proto* f; - int i; - if (!lua_checkstack(L,argc)) fatal("too many input files"); - for (i=0; i1); - if (dumping) - { - FILE* D= (output==NULL) ? stdout : fopen(output,"wb"); - if (D==NULL) cannot("open"); - lua_lock(L); - luaU_dump(L,f,writer,D,stripping); - lua_unlock(L); - if (ferror(D)) cannot("write"); - if (fclose(D)) cannot("close"); - } - return 0; -} - -int main(int argc, char* argv[]) -{ - lua_State* L; - struct Smain s; - int i=doargs(argc,argv); - argc-=i; argv+=i; - if (argc<=0) usage("no input files given"); - L=lua_open(); - if (L==NULL) fatal("not enough memory for state"); - s.argc=argc; - s.argv=argv; - if (lua_cpcall(L,pmain,&s)!=0) fatal(lua_tostring(L,-1)); - lua_close(L); - return EXIT_SUCCESS; -} diff --git a/tests/HsLuaMain.hs b/tests/HsLuaMain.hs --- a/tests/HsLuaMain.hs +++ b/tests/HsLuaMain.hs @@ -96,7 +96,7 @@ v <- Lua.newcfunction test1 Lua.push l v Lua.setglobal l "test1" - + putStrLn "NEXT: Got 1 test1" Lua.callproc l "test1" (1.0::Double) "test1"