hslua 0.1 → 0.2
raw patch · 6 files changed
+29/−648 lines, 6 files
Files
- hslua.cabal +2/−3
- src/HsLuaMain.hs +0/−46
- src/Scripting/Lua.hs +26/−8
- src/lua.c +0/−390
- src/luac.c +0/−200
- tests/HsLuaMain.hs +1/−1
hslua.cabal view
@@ -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 <gracjanpolak@gmail.com> Maintainer: Gracjan Polak <gracjanpolak@gmail.com>-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.
− src/HsLuaMain.hs
@@ -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
src/Scripting/Lua.hs view
@@ -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
− src/lua.c
@@ -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 <signal.h>-#include <stdio.h>-#include <stdlib.h>-#include <string.h>--#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("<eof>")) - 1);- if (strstr(msg, LUA_QL("<eof>")) == 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;-}-
− src/luac.c
@@ -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 <errno.h>-#include <stdio.h>-#include <stdlib.h>-#include <string.h>--#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; i<argc; i++)- {- if (*argv[i]!='-') /* end of options; keep it */- break;- else if (IS("--")) /* end of options; skip it */- {- ++i;- if (version) ++version;- break;- }- else if (IS("-")) /* end of options; use stdin */- break;- else if (IS("-l")) /* list */- ++listing;- else if (IS("-o")) /* output file */- {- output=argv[++i];- if (output==NULL || *output==0) usage(LUA_QL("-o") " needs argument");- if (IS("-")) output=NULL;- }- else if (IS("-p")) /* parse only */- dumping=0;- else if (IS("-s")) /* strip debug information */- stripping=1;- else if (IS("-v")) /* show version */- ++version;- else /* unknown option */- usage(argv[i]);- }- if (i==argc && (listing || !dumping))- {- dumping=0;- argv[--i]=Output;- }- if (version)- {- printf("%s %s\n",LUA_RELEASE,LUA_COPYRIGHT);- if (version==argc-1) exit(EXIT_SUCCESS);- }- return i;-}--#define toproto(L,i) (clvalue(L->top+(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; i<n; i++)- {- f->p[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; i<argc; i++)- {- const char* filename=IS("-") ? NULL : argv[i];- if (luaL_loadfile(L,filename)!=0) fatal(lua_tostring(L,-1));- }- f=combine(L,argc);- if (listing) luaU_print(f,listing>1);- 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;-}
tests/HsLuaMain.hs view
@@ -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"