C4Cypher

state.m

Aug 29th, 2014
243
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. %-----------------------------------------------------------------------------%
  2. % vim: ft=mercury
  3. %-----------------------------------------------------------------------------%
  4. % Copyright (C) 2014 Charlie H. McGee IV.
  5. % This file may only be copied under the terms of the GNU Library General
  6. % Public License - see the file COPYING.LIB in the Mercury distribution.
  7. %-----------------------------------------------------------------------------%
  8. %
  9. % File: api.m.
  10. % Main author: C4Cypher.
  11. % Stability: low.
  12. %
  13. % This file provides access to some of the impure, lower level calls of the
  14. % Lua API for manipulating the Lua state.
  15. %
  16. %
  17. % Each function call is provided with a local stack which function arguments
  18. % are pushed onto before the call.  The function call returns an integer
  19. % and Lua uses that number to determine the number of return values to take
  20. % off the top of the stack (from the bottom up).  In both cases the first
  21. % argument is pushed first, with the last argument on the top of the stack.
  22. %
  23. % Values on the stack can be refrenced by integer index values. Positive
  24. % integers refrence values from the bottom of the stack, starting at one,
  25. % while negative integers refrences the stack from the top down (-1 referring
  26. % to the value at the top of the stack).
  27. %
  28. % Due to the fact that different versions of Lua handle the global environment
  29. % and the registry in different ways, for the sake of compatability, this
  30. % library will not permit the explicit use of pseudo-indexes.  Instead,
  31. % seperate access predicates have been provided in the place of pseudo-indexes.
  32. %
  33. % Warning: Lua employs minimal error checking when performing low level
  34. % stack operations. It trusts that code directly manipulating the stack
  35. % will avoid using invalid stack refrences or stack overflows through the use
  36. % of top, get_top, set_top and check_stack.  For more information, refer
  37. % to the Lua Refrence Manual, and the examples provided at the Lua User's Wiki.
  38. %
  39. %-----------------------------------------------------------------------------%
  40. %-----------------------------------------------------------------------------%
  41.  
  42. :- module api.
  43.  
  44. :- interface.
  45.  
  46. %:- import_module stream.
  47.  
  48. % Note: These methods are unsafe without a clear understanding of the workings
  49. % of the Lua C api, and even then, they're still pretty unsafe.
  50.  
  51.  
  52.  
  53.  
  54.  
  55.  
  56. % Visualizing the Lua stack
  57. %
  58. % The stack will be illustrated using list syntax, the numbers underneath
  59. % represent the indexes used to refer to those values in the stack using
  60. % Lua api calls.
  61. %
  62. % Example: [A, B, C, ... X, Y, Z]
  63. %           1  2  3     -3 -2 -1
  64. %
  65. % Here a is at the bottom of the stack at index 1, and z is at the top of
  66. % the stack at index -1.  0 is never a valid index
  67. %
  68. % I'll be using haskell style function arrows to illustrate stack operations
  69. %
  70. % Example:
  71. % push(Z, L) :: [... X, Y] -> [... X, Y, Z]
  72. %                   -2 -1         -3 -2 -1
  73.  
  74.  
  75. %-----------------------------------------------------------------------------%
  76. %
  77. % Stack indexes
  78. %
  79.  
  80.     % The index of the registry
  81. :- func registryindex = index.
  82.  
  83.     % The index of the global environment
  84. :- func globalindex = index.
  85.  
  86. :- func index(int) = index.
  87.  
  88.     % Get the absolute stack position
  89. :- semipure func absolute(lua, index) = index.
  90.  
  91. %-----------------------------------------------------------------------------%
  92. %
  93. % Stack Manipulation
  94. %
  95.  
  96.     % The index at the top of the stack.
  97. :- semipure func lua_gettop(lua) = int.
  98.  
  99.     % settop(N, L) :: [... X, Y, Z] -> [... X, Y]
  100.     %                         N                N
  101.     % settop(N + 2, L) :: [... X] -> [... X, nil, nil]
  102.     %                          N          N  N+1  N+2
  103.     %
  104. :- impure pred lua_settop(lua::in, int::in) is det.
  105.  
  106.     % Allocate free space on the stack if needed, fail if it cannot
  107. :- semipure pred lua_checkstack(lua::in, int::in) is semidet.
  108.  
  109.     % Directly push values from a different stack index
  110. :- impure pred  lua_pushvalue(lua::in, index::in) is det.
  111.  
  112.     % Pop a number of values off the stack.
  113. :- impure pred  lua_pop(lua::in, int::in) is det.
  114.  
  115. % Note: Use of lua_remove and lua_insert is highly discouraged when used with
  116. % this library, given that said operations impurely re-arrange the Lua stack
  117. % in a manner that ignores restrictions that Mercury needs to interact with
  118. % it purely. Furthermore, the indexes provided to the following procedures
  119. % MUST be valid indexes on the stack, not pseudo-indexes such as
  120. % registryindex or globalindex.
  121.  
  122.     % Remove a value from the stack at a given index, shifting the elments
  123.     % above it down(dangerous)
  124.     %
  125. :- impure pred lua_remove(lua::in, index::in) is det.
  126.  
  127.     % Pop a value from the top of the stack and use it to replace the
  128.     % value at the given stack index, without disturbing the rest of the
  129.     % stack.
  130. :- impure pred lua_replace(lua::in, index::in) is det.
  131.  
  132.     % Pop a value from the top of the stack, and insert it at the
  133.     % given stack index, shifting elements up.
  134. :- impure pred lua_insert(lua::in, index::in) is det.
  135.  
  136. %-----------------------------------------------------------------------------%
  137. %
  138. % Pushing Mercury values and vars onto the stack
  139. %
  140.  
  141.     % Push a luaMR.value onto the Lua stack
  142. :- impure pred push_value(lua::in, value::in) is det.
  143.  
  144.     % Push a luaMR.var onto the stack
  145. :- impure pred push_var(lua::in, var::in) is det.
  146.  
  147.  
  148.  
  149. %-----------------------------------------------------------------------------%
  150. %
  151. % Accessing and manipulating variables
  152. %
  153.  
  154.    
  155.     % The Lua type of a value on the stack
  156.     %
  157. :- semipure func lua_type(lua, index) = lua_type.
  158.    
  159.     % The Lua type of a stack value as a string
  160.     %
  161. :- semipure func lua_typename(lua, index) = string.
  162.  
  163. % Get calls will remove the key from the top of the table and replace it
  164. % with the value.
  165. %
  166. % Lua: v = t[k]
  167. % get(L, N) :: [... t, ... k] -> [... t, ... v]
  168. %                   N     -1          N     -1
  169. %
  170. % Set calls will remove both the key and the value from the top of the stack.
  171. %
  172. % Lua: t[k] = v
  173. % set(L, N) :: [... t, ... _, k, v] -> [... t, ... _]
  174. %                   N      X  Y  Z          N      X
  175.  
  176.    
  177.     % Access Lua tables without invoking metamethods
  178.     %
  179. :- impure pred lua_rawget(lua::in, index::in) is det.
  180. :- impure pred lua_rawset(lua::in, index::in) is det.
  181.  
  182.     % Access the array portion of a Lua table without invoking metamethods
  183.     %
  184. :- impure pred lua_rawgeti(lua::in, index::in, int::in) is det.
  185. :- impure pred lua_rawseti(lua::in, index::in, int::in) is det.
  186.  
  187.     % Access Lua tables, if Raw is yes, metamethod invocations are avoided,
  188.     % but an error is thrown if Table is not actually a table.
  189.     %
  190. :- impure pred lua_gettable(lua::in, index::in) is det.
  191. :- impure pred lua_settable(lua::in, index::in) is det.
  192.    
  193.     % Access a value from a table using a string key
  194.     %
  195. :- impure pred lua_getfield(lua::in, index::in, string::in) is det.
  196. :- impure pred lua_setfield(lua::in, index::in, string::in) is det.
  197.  
  198.     % Access metatables, may cause undefined behavior if used on types
  199.     % that do not have metatables.
  200.     %
  201. :- impure pred lua_getmetatable(lua::in, index::in) is semidet.
  202. :- impure pred lua_setmetatable(lua::in, index::in) is det.
  203.  
  204.     % Create an empty table and push it onto the stack.
  205.     %
  206. :- impure pred lua_newtable(lua::in) is det.
  207.  
  208.     % Pop a key from the top of the stack and push the key-value pair
  209.     % corresponding to the 'next' value associated with the table at
  210.     % the given index.
  211.     %
  212. :- impure pred lua_next(lua::in, index::in) is det.
  213.  
  214. %-----------------------------------------------------------------------------%
  215. %
  216. % The registry, and upvalues.
  217. %
  218.  
  219.     % Access the registry
  220.     %
  221. :- impure pred lua_getregistry(lua::in, string::in) is det.
  222. :- impure pred lua_setregistry(lua::in, string::in) is det.
  223.  
  224.     % Access an upvalue
  225.     %
  226. :- impure pred lua_getupvalue(lua::in, int::in) is semidet.
  227. :- impure pred lua_setupvalue(lua::in, int::in) is det.
  228.  
  229. %-----------------------------------------------------------------------------%
  230. %
  231. % Function constructors, deconstructors, and calls
  232. %
  233.  
  234.  
  235.     % Load a function from a string.
  236. :- impure func lua_loadstring(lua, string) = status is det.
  237.  
  238.     % lua_call(L, Args, Results)
  239.     % lua_call(L, Args) = Results]
  240.     % call a function
  241. :- impure pred lua_call(lua::in, int::in, int::in) is det.
  242. :- impure func lua_call(lua, int) = int.
  243.  
  244.     % lua_pcall(L, Args, Results, Error_handler) = Result.
  245.     % lua_pcall(L, Args, Error_handler) = Result.
  246.     % lua_pcall(L, Args) = Returned.
  247.     % call a function with an error handler. If
  248.     % no error handler is
  249. :- impure func lua_pcall(lua, int, int, index) = lua_result.
  250. :- impure func lua_pcall(lua, int, index) = lua_result.
  251. :- impure func lua_pcall(lua, int) = int.
  252.  
  253.  
  254.     % Call a mercury function from C
  255.     %
  256. :- impure func mr_call(lua) = int.
  257.  
  258. :- type lua_result
  259.     --->    returned(int)
  260.     ;   returned_error(lua_error).
  261.  
  262.     % cpcall(CFunc, LUdataIn, L) = LUdataOut
  263.     %
  264.     % Protected C call in Lua, passing a pointer (or MR_Word)
  265.     % as the only argument.  
  266.     %
  267. :- impure func lua_cpcall(lua, c_function, c_pointer) = c_pointer.
  268.  
  269. % TODO: Should lua_error/2/3 be failure?
  270.  
  271.     % Throw an error from Mercury to Lua, passing the value on the stack
  272.     % as the error value.
  273.     %
  274. :- impure pred lua_error(lua::in) is erroneous.
  275.  
  276.     % Throw an error from Mercury to Lua, passing the given value
  277.     % as the error value.
  278.     %
  279. :- impure pred lua_error(lua::in, T::in) is erroneous.
  280.  
  281.  
  282.  
  283.  
  284. %-----------------------------------------------------------------------------%
  285. %
  286. % Utilites for the concrete Lua state.
  287. %
  288.  
  289.     % Create a fresh, new , initialized lua.
  290.     %
  291. :- func lua_new = lua.
  292.  
  293.  
  294.     % Destroy a lua
  295.     %
  296. :- impure pred lua_close(lua::in) is det.  
  297.  
  298.  
  299.     % Return the Lua state's current status.
  300.     %
  301. :- semipure func lua_status(lua) = status.
  302.  
  303.  
  304. :- type status
  305.     --->    ready
  306.     ;   yield
  307.     ;   runtime_error
  308.     ;   syntax_error
  309.     ;   memory_error
  310.     ;   unhandled_error.
  311.  
  312. %-----------------------------------------------------------------------------%
  313. %-----------------------------------------------------------------------------%
  314. %
  315. % Value passing
  316. %
  317.  
  318. :- semipure pred lua_isnumber(lua::in, index::in) is semidet.
  319. :- semipure pred lua_isnil(lua::in, index::in) is semidet.
  320. :- semipure pred lua_isuserdata(lua::in, index::in) is semidet.
  321. :- semipure pred lua_ismruserdata(lua::in, index::in) is semidet.
  322. :- semipure pred lua_isinteger(lua::in, index::in) is semidet.
  323. :- semipure pred lua_islightuserdata(lua::in, index::in) is semidet.
  324. :- semipure pred lua_isstring(lua::in, index::in) is semidet.
  325. :- semipure pred lua_istable(lua::in, index::in) is semidet.
  326. :- semipure pred lua_isboolean(lua::in, index::in) is semidet.
  327. :- semipure pred lua_isthread(lua::in, index::in) is semidet.
  328. :- semipure pred lua_isfunction(lua::in, index::in) is semidet.
  329. :- semipure pred lua_iscfunction(lua::in, index::in) is semidet.
  330.  
  331. :- semipure func lua_tonumber(lua, index) = float.
  332. :- semipure func lua_touserdata(lua, index) = univ.
  333. :- semipure func lua_tocuserdata(lua, index) = c_pointer.
  334. :- semipure func lua_tointeger(lua, index) = int.
  335. :- semipure func lua_tostring(lua, index) = string.
  336. :- semipure func lua_toboolean(lua, index) = bool.
  337. :- semipure func lua_tothread(lua, index) = lua.
  338. :- semipure func lua_tocfunction(lua, index) = c_function.
  339. :- semipure func lua_toref(lua, index) = ref.
  340.  
  341. :- impure pred lua_pushnil(lua::in) is det.
  342. :- impure pred lua_pushnumber(lua::in, float::in) is det.
  343. :- impure pred lua_pushuserdata(lua::in, T::in) is det.
  344. :- impure pred lua_pushuniv(lua::in, univ::in) is det.
  345. :- impure pred lua_pushinteger(lua::in, int::in) is det.
  346. :- impure pred lua_pushlightuserdata(lua::in, c_pointer::in) is det.
  347. :- impure pred lua_pushstring(lua::in, string::in) is det.
  348. :- impure pred lua_pushboolean(lua::in, bool::in) is det.
  349. :- impure pred lua_pushthread(lua::in) is det.
  350. :- impure func lua_pushthread(lua) = bool.
  351. :- impure pred lua_pushfunc(lua, lua_func).
  352. :- mode lua_pushfunc(in, dfi) is det.
  353. :- mode lua_pushfunc(in, sfi) is det.
  354. :- impure pred lua_pushcfunction(lua::in, c_function::in) is det.
  355. :- impure pred lua_pushcclosure(lua::in, c_function::in, int::in) is det.
  356. :- impure pred lua_pushref(lua::in, ref::in) is det.
  357.  
  358. %-----------------------------------------------------------------------------%
  359. %-----------------------------------------------------------------------------%
  360.  
  361. :- implementation.
  362.  
  363. :- import_module require.
  364. :- import_module exception.
  365. :- import_module solutions.
  366.  
  367. :- pragma foreign_decl("C", "
  368. #include <lua.h>
  369. #include <lauxlib.h>
  370. #include <lualib.h>
  371. ").
  372.  
  373. %-----------------------------------------------------------------------------%
  374. %
  375. % Stack indexes
  376. %
  377.  
  378.  
  379.  
  380. :- pragma foreign_proc("C", registryindex = (I::out),
  381.     [promise_pure, will_not_call_mercury], "I = LUA_REGISTRYINDEX;").
  382.    
  383. :- pragma foreign_proc("C", globalindex = (I::out),
  384.     [promise_pure, will_not_call_mercury], "I = LUA_GLOBALSINDEX;").
  385.    
  386. index(I) = I.
  387.  
  388. :- pragma inline(index/1).
  389.  
  390. :- pragma foreign_proc("C", absolute(L::in, I::in) = (A::out),
  391.     [promise_semipure, will_not_call_mercury], "
  392.     A = I > 0 ? I : lua_gettop(L) + 1 + I;").
  393.    
  394. :- pragma inline(absolute/2).
  395.    
  396. :- pragma foreign_export("C", absolute(in, in) = out, "luaMR_absolute").
  397.  
  398.  
  399. %-----------------------------------------------------------------------------%
  400. %
  401. % Stack Manipulation
  402. %
  403.  
  404. :- pragma foreign_proc("C", lua_gettop(L::in) = (Index::out),
  405.     [promise_semipure, will_not_call_mercury],
  406.     "Index = lua_gettop(L); ").
  407.    
  408. :- pragma inline(lua_gettop/1).
  409.    
  410. :- pragma foreign_proc("C",  lua_settop(L::in, Index::in),
  411.     [will_not_call_mercury],
  412.     "lua_settop(L, Index);").
  413.    
  414. :- pragma inline(lua_settop/2).
  415.  
  416. :- pragma foreign_proc("C",  lua_checkstack(L::in, Free::in),
  417.     [will_not_call_mercury, promise_semipure], "lua_checkstack(L, Free);").
  418.    
  419. :- pragma inline(lua_checkstack/2).
  420.  
  421. :- pragma foreign_proc("C",  lua_pushvalue(L::in, I::in),
  422.     [will_not_call_mercury], "lua_pushvalue(L, I);").
  423.    
  424. :- pragma inline(lua_pushvalue/2).
  425.  
  426. :- pragma foreign_proc("C",  lua_pop(L::in, Num::in),
  427.     [will_not_call_mercury], "lua_pop(L, Num);").
  428.    
  429. :- pragma inline(lua_pop/2).
  430.  
  431. :- pragma foreign_proc("C",  lua_remove(L::in, Index::in),
  432.     [will_not_call_mercury], "lua_remove(L, Index);").
  433.    
  434. :- pragma inline(lua_remove/2).
  435.  
  436. :- pragma foreign_proc("C",  lua_replace(L::in, Index::in),
  437.     [will_not_call_mercury], "lua_replace(L, Index);").
  438.    
  439. :- pragma inline(lua_replace/2).
  440.  
  441. :- pragma foreign_proc("C",  lua_insert(L::in, Index::in),
  442.     [will_not_call_mercury], "lua_insert(L, Index);").
  443.    
  444. :- pragma inline(lua_insert/2).
  445.  
  446. %-----------------------------------------------------------------------------%
  447. %
  448. % Pushing Mercury values and vars onto the stack
  449. %
  450.  
  451. push_value(L, V) :-
  452.     require_complete_switch [V]
  453.     ( V = nil(_) ->
  454.         impure lua_pushnil(L)
  455.     ; V = number(F) ->
  456.         impure lua_pushnumber(L, F)
  457.     ; V = integer(I) ->
  458.         impure lua_pushinteger(L, I)
  459.     ; V = boolean(B) ->
  460.         impure lua_pushboolean(L, B)
  461.     ; V = string(S) ->
  462.         impure lua_pushstring(L, S)
  463.     ; V = lightuserdata(P) ->
  464.         impure lua_pushlightuserdata(L, P)
  465.     ; V = thread(L2) ->
  466.         (L2 = L -> impure lua_pushthread(L)
  467.         ; error("Can only push the active thread onto the stack.")
  468.         )
  469.     ; V = c_function(F) ->
  470.         impure lua_pushcfunction(L, F)
  471.     ; V = var(Var) ->
  472.         impure push_var(L, Var)
  473.     ; V = userdata(U) ->
  474.         impure lua_pushuniv(L, U)
  475.     ; V = lua_error(E) ->
  476.         impure lua_error(L, E)
  477.     ; V = unbound ->
  478.         impure lua_pushuserdata(L, V)
  479.     ; unexpected($module, $pred, "Attempted to push an unexpected value: "
  480.         ++ string.string(V))
  481.     ).
  482.    
  483. push_var(L, V) :-
  484.     require_complete_switch [V]
  485.     ( V = local(I) -> impure lua_pushvalue(L, I)
  486.     ; V = index(Val, Table) ->
  487.         ( Val = nil(_) -> impure lua_pushnil(L)
  488.         ; Val = unbound -> throw(lua_error(runtime_error,
  489.             "attempt to index var " ++ string(Table) ++
  490.             " by an unbound value."))
  491.         ; impure push_var(L, Table), semipure lua_isnil(L, -1) ->
  492.             throw(lua_error(
  493.             runtime_error, "attempt to index var "
  494.             ++ string.string(Table) ++
  495.             " (a nil value)."))
  496.         ;
  497.             impure push_value(L, Val),
  498.             impure lua_rawget(L, -2),
  499.             impure lua_remove(L, -2)
  500.         )
  501.     ; V = meta(Table) ->
  502.         impure push_var(L, Table),
  503.         ( impure lua_getmetatable(L, -1) ->
  504.             impure lua_remove(L, -2)
  505.         ;
  506.             impure lua_pop(L, 1),
  507.             impure lua_pushnil(L)
  508.         )
  509.     ; V = ref(R) -> impure lua_pushref(L, R)
  510.     ; V = global(S) ->
  511.         impure lua_pushvalue(L, globalindex),
  512.         impure lua_pushstring(L, S),
  513.         impure lua_rawget(L, -2),
  514.         impure lua_remove(L, -2)
  515.     ; V = invalid(S) ->
  516.         throw(lua_error(runtime_error, $module ++ "." ++ $pred ++
  517.         " attempted to push invalid var: " ++ S))
  518.     ; unexpected($module, $pred, "Switch on var V failed.")
  519.     ).
  520.  
  521. %-----------------------------------------------------------------------------%
  522. %
  523. % Accessing and manipulating variables
  524. %
  525.  
  526. :- pragma foreign_proc("C",  lua_type(L::in, Index::in) = (Type::out),
  527.     [promise_semipure, will_not_call_mercury],
  528.     "Type = lua_type(L, Index);").
  529.    
  530. :- pragma inline(lua_type/2).
  531.    
  532. :- pragma foreign_proc("C",  lua_typename(L::in, Index::in) = (Name::out),
  533.     [promise_semipure, will_not_call_mercury],
  534.     "Name = (char *)lua_typename(L, lua_type(L, Index));").
  535.    
  536. :- pragma inline(lua_typename/2).
  537.  
  538.  
  539. :- pragma foreign_proc("C", lua_rawget(L::in, I::in),
  540.     [will_not_call_mercury], "lua_rawget(L, I);").
  541.    
  542. :- pragma inline(lua_rawget/2).
  543.      
  544. :- pragma foreign_proc("C", lua_rawset(L::in, I::in),
  545.     [will_not_call_mercury], "lua_rawset(L, I);").
  546.    
  547. :- pragma inline(lua_rawset/2).
  548.  
  549. :- pragma foreign_proc("C", lua_rawgeti(L::in, I::in, N::in),
  550.     [will_not_call_mercury], "lua_rawgeti(L, I, N);").
  551.    
  552. :- pragma inline(lua_rawgeti/3).
  553.      
  554. :- pragma foreign_proc("C", lua_rawseti(L::in, I::in, N::in),
  555.     [will_not_call_mercury], "lua_rawseti(L, I, N);").
  556.    
  557. :- pragma inline(lua_rawseti/3).
  558.  
  559. :- pragma foreign_proc("C", lua_gettable(L::in, I::in),
  560.     [may_call_mercury], "lua_gettable(L, I);").
  561.    
  562. :- pragma inline(lua_gettable/2).
  563.    
  564. :- pragma foreign_proc("C", lua_settable(L::in, I::in),
  565.     [may_call_mercury], "lua_settable(L, I);").
  566.    
  567. :- pragma inline(lua_settable/2).
  568.    
  569. :- pragma foreign_proc("C", lua_getfield(L::in, I::in, K::in),
  570.     [may_call_mercury], "lua_getfield(L, I, K);").
  571.    
  572. :- pragma inline(lua_getfield/3).
  573.    
  574. :- pragma foreign_proc("C", lua_setfield(L::in, I::in, K::in),
  575.     [will_not_call_mercury], "lua_setfield(L, I, K);").
  576.  
  577. :- pragma inline(lua_setfield/3).
  578.    
  579. :- pragma foreign_proc("C", lua_getmetatable(L::in, I::in),
  580.     [may_call_mercury],
  581.     "SUCCESS_INDICATOR = lua_getmetatable(L, I);").
  582.    
  583. :- pragma inline(lua_getmetatable/2).
  584.  
  585. :- pragma foreign_proc("C", lua_setmetatable(L::in, I0::in),
  586.     [may_call_mercury], "
  587.     int I = luaMR_absolute(L, I0);
  588.     lua_setmetatable(L, I);
  589.     if(luaMR_ismruserdata(L, I))
  590.         luaMR_set_userdata_metatable(L, I);
  591. ").
  592.  
  593. :- pragma inline(lua_setmetatable/2).
  594.  
  595. :- pragma foreign_proc("C", lua_newtable(L::in),
  596.     [will_not_call_mercury], "lua_newtable(L);").
  597.    
  598. :- pragma inline(lua_newtable/1).
  599.  
  600. :- pragma foreign_proc("C", lua_next(L::in, I::in),
  601.     [may_call_mercury], "lua_next(L, I);").
  602.    
  603. :- pragma inline(lua_next/2).
  604.  
  605. %-----------------------------------------------------------------------------%
  606. %
  607. % The registry, and upvalues.
  608. %
  609.  
  610. :- pragma foreign_proc("C", lua_getregistry(L::in, I::in),
  611.     [will_not_call_mercury], "luaMR_getregistry(L, I);").
  612.    
  613. :- pragma inline(lua_getregistry/2).
  614.  
  615. :- pragma foreign_proc("C", lua_setregistry(L::in, I::in),
  616.     [will_not_call_mercury], "luaMR_setregistry(L, I);").
  617.    
  618. :- pragma inline(lua_setregistry/2).
  619.    
  620.    
  621. :- pragma foreign_proc("C", lua_getupvalue(L::in, I::in),
  622.     [will_not_call_mercury], "
  623.     SUCCESS_INDICATOR = luaMR_getupvalue(L, I);
  624. ").
  625.  
  626. :- pragma inline(lua_getupvalue/2).
  627.  
  628. :- pragma foreign_proc("C", lua_setupvalue(L::in, I::in),
  629.     [will_not_call_mercury], "luaMR_setupvalue(L, I);").
  630.    
  631. :- pragma inline(lua_setupvalue/2).
  632.  
  633. %-----------------------------------------------------------------------------%
  634. %
  635. % Function constructors, deconstructors, and calls
  636. %
  637.  
  638. :- pragma foreign_proc("C", lua_loadstring(L::in, S::in) = (Success::out),
  639.     [may_call_mercury], "Success = luaL_loadstring(L, S);").
  640.    
  641. :- pragma inline(lua_loadstring/2).
  642.    
  643. :- pragma foreign_proc("C", lua_call(L::in, Args::in, Ret::in),
  644.     [may_call_mercury], "lua_call(L, Args, Ret);").
  645.    
  646. :- pragma inline(lua_call/3).
  647.    
  648. lua_call(L, A) = R :-
  649.     semipure T1 = lua_gettop(L),
  650.     S = T1 - A - 1,
  651.     impure lua_call(L, A, multret),
  652.     semipure T2 = lua_gettop(L),
  653.     R = T2 - S.
  654.  
  655.  
  656. lua_pcall(L, A, R, E) = Result :-
  657.     semipure T1 = lua_gettop(L),
  658.     S = T1 - A - 1,
  659.     impure Error = lua_pcall2(L, A, R, E),
  660.     ( Error = no_error ->
  661.         semipure T2 = lua_gettop(L),
  662.         Result = returned(T2 - S)
  663.     ;
  664.         semipure Message = lua_tostring(L, -1),
  665.         impure lua_pop(L, 1),
  666.         Result = returned_error(lua_error(Error, Message))
  667.     ).
  668.  
  669. :- impure func lua_pcall2(lua, int, int, index) = error_type.
  670.  
  671. :- pragma foreign_proc("C", lua_pcall2(L::in, Args::in, Ret::in, Err::in)
  672.         = (Result::out),
  673.     [may_call_mercury], " Result = lua_pcall(L, Args, Ret, Err);").
  674.    
  675. :- pragma inline(lua_pcall/4).
  676.    
  677. lua_pcall(L, A, E) = R :-
  678.     impure R = lua_pcall(L, A, multret, E).
  679.    
  680. lua_pcall(L, A) = R :-
  681.     impure Result = lua_pcall(L, A, 0),
  682.     ( Result = returned(R)
  683.     ; Result = returned_error(Error), throw(Error)
  684.     ; unexpected($module, $pred, "Invalid result value. (WTF?)")   
  685.     ).
  686.    
  687. :- pragma foreign_proc("C", lua_cpcall(L::in, Func::in, Ptr::in) = (R::out),
  688.     [may_call_mercury], "
  689.     R = lua_cpcall(L, Func, (void *)Ptr);
  690.     ").
  691.  
  692.  
  693. :- func multret = int.
  694.  
  695. :- pragma foreign_proc("C", multret = (M::out),
  696.     [promise_pure, will_not_call_mercury], "M = LUA_MULTRET;").
  697.    
  698. :- pragma inline(multret/0).
  699.  
  700.  
  701. mr_call(L) = R :-
  702.     promise_equivalent_solutions [E] (try(mr_call(L), E)),
  703.     require_complete_switch [E]
  704.     ( E = succeeded(R)
  705.     ; E = failed,
  706.         impure lua_pushboolean(L, no),
  707.         R = 1
  708.     ; E = exception(Ex),
  709.         impure lua_pushnil(L),
  710.         impure lua_pushuserdata(L, Ex),
  711.         R = 2
  712.     ).
  713.        
  714.  
  715. :- pred mr_call(lua::in, int::out) is semidet.
  716.    
  717. mr_call(L,  R) :-
  718.     impure lua_getupvalue(L, 1),
  719.     semipure lua_touserdata(L, -1) = U,
  720.     U = univ(FU) ->
  721.         require_complete_switch [FU]
  722.         ( FU = det_func(F) ; FU = semidet_func(F) ),
  723.         impure R = impure_apply(F,L)   
  724.     ;
  725.         error(
  726.         "Called Mercury function without valid func upvalue.").
  727.        
  728. :- pragma promise_pure(mr_call/2).
  729.        
  730. :- pragma foreign_export("C", mr_call(in) = out, "luaMR_call").
  731.    
  732. :- func mr_call_ptr = c_function.
  733.  
  734. :- pragma foreign_proc("C", mr_call_ptr = (F::out),
  735.     [promise_pure, will_not_call_mercury], "F = (lua_CFunction)luaMR_call;").
  736.  
  737. :- pragma foreign_proc("C", lua_error(L::in),
  738.     [may_call_mercury],"lua_error(L);").
  739.    
  740. :- pragma inline(lua_error/1).
  741.    
  742. lua_error(L, T) :-
  743.     impure lua_pushuserdata(L, T),
  744.     impure lua_error(L).
  745.    
  746.  
  747. %-----------------------------------------------------------------------------%
  748. %
  749. % Utilites for the concrete Lua state.
  750. %
  751.  
  752.    
  753.    
  754. :- func return_nil = nil.
  755.  
  756. return_nil = nil.
  757.  
  758. :- pragma inline(return_nil/0).
  759.  
  760. :- pragma foreign_export("C", return_nil = out, "luaMR_nil").
  761.  
  762. :- pragma foreign_proc("C", lua_new = (L::out),
  763.     [promise_pure, will_not_call_mercury], "
  764.     void * ptr = MR_malloc(sizeof(ptr));
  765.     L = lua_newstate((lua_Alloc)luaMR_alloc, ptr);
  766.     luaL_openlibs(L);
  767.     luaMR_init(L);
  768.     ").
  769.    
  770. :- pragma foreign_decl("C", "
  771.     void * luaMR_alloc(void *, void *, size_t, size_t);").
  772.    
  773. :- pragma foreign_code("C", "
  774.     void * luaMR_alloc(void * ud, void * ptr,
  775.             size_t osize, size_t nsize) {
  776.         (void)ud;
  777.         if(nsize == 0) {
  778.             if(osize == 0)
  779.                 return NULL;
  780.             else
  781.                 MR_GC_free(ptr);
  782.                 return NULL;
  783.         } else {
  784.             if(osize == 0) {
  785.                 ptr = MR_GC_malloc(nsize);
  786.                 return ptr;
  787.             } else {
  788.                 ptr = MR_GC_realloc(ptr,nsize);
  789.                 return ptr;
  790.             }
  791.         }
  792.     }
  793. ").
  794.    
  795.    
  796. :- pragma inline(lua_new/0).
  797.    
  798.  
  799. :- pragma foreign_proc("C", lua_close(L::in),
  800.     [may_call_mercury], "lua_close(L);").
  801.    
  802. :- pragma foreign_proc("C", lua_status(L::in) = (S::out),
  803.     [promise_semipure, will_not_call_mercury], "S = lua_status(L);").
  804.  
  805. :- pragma foreign_enum("C", status/0, [
  806.     ready - "0",
  807.     yield - "LUA_YIELD",
  808.     runtime_error - "LUA_ERRRUN",
  809.     syntax_error - "LUA_ERRSYNTAX",
  810.     memory_error - "LUA_ERRMEM",
  811.     unhandled_error - "LUA_ERRERR"
  812. ] ).
  813.  
  814.  
  815. %-----------------------------------------------------------------------------%
  816. %
  817. % Value Passing
  818. %
  819.  
  820. :- pragma foreign_proc("C", lua_isnumber(L::in, Index::in),
  821.     [promise_semipure, will_not_call_mercury],
  822.     " SUCCESS_INDICATOR = lua_isnumber(L, Index);").
  823.    
  824. :- pragma inline(lua_isnumber/2).
  825.  
  826. :- pragma foreign_proc("C", lua_isstring(L::in, Index::in),
  827.     [promise_semipure, will_not_call_mercury],
  828.     " SUCCESS_INDICATOR = lua_isstring(L, Index);").
  829.    
  830. :- pragma inline(lua_isstring/2).
  831.  
  832. :- pragma foreign_proc("C", lua_isinteger(L::in, Index::in),
  833.     [promise_semipure, will_not_call_mercury],
  834. "
  835.     if(lua_isnumber(L, Index));
  836.      SUCCESS_INDICATOR =
  837.         !(lua_tonumber(L, Index) - lua_tointeger(L, Index));").
  838.        
  839. :- pragma inline(lua_isinteger/2).
  840.  
  841. :- pragma foreign_proc("C", lua_isthread(L::in, Index::in),
  842.     [promise_semipure, will_not_call_mercury],
  843.     "SUCCESS_INDICATOR = lua_isthread(L, Index);").
  844.    
  845. :- pragma inline(lua_isthread/2).
  846.  
  847. :- pragma foreign_proc("C", lua_isnil(L::in, Index::in),
  848.     [promise_semipure, will_not_call_mercury],
  849.     "SUCCESS_INDICATOR = lua_isnil(L, Index);").
  850.    
  851. :- pragma inline(lua_isnil/2).
  852.  
  853. :- pragma foreign_proc("C", lua_isuserdata(L::in, Index::in),
  854.     [promise_semipure, will_not_call_mercury],
  855.     "SUCCESS_INDICATOR = lua_isuserdata(L, Index);").
  856.    
  857. :- pragma inline(lua_isuserdata/2).
  858.  
  859. :- pragma foreign_proc("C", lua_ismruserdata(L::in, Index::in),
  860.     [promise_semipure, will_not_call_mercury], "
  861.     int Top = lua_gettop(L);
  862.     lua_pushvalue(L, Index); /* 1 */   
  863.     if(lua_isuserdata(L, -1) && lua_getmetatable(L, -1)) { /* 2 */
  864.         lua_pushstring(L, LUA_MR_USERDATA);
  865.         lua_rawget(L, -2);
  866.         SUCCESS_INDICATOR = lua_toboolean(L, -1);
  867.         lua_settop(L, Top);
  868.     } else {
  869.         SUCCESS_INDICATOR = 0;
  870.         lua_settop(L, Top);
  871.     }
  872. ").
  873.        
  874. :- pragma foreign_export("C", lua_ismruserdata(in, in),
  875.     "luaMR_ismruserdata").
  876.    
  877. :- pragma foreign_proc("C", lua_istable(L::in, Index::in),
  878.     [promise_semipure, will_not_call_mercury],
  879.     "SUCCESS_INDICATOR = lua_istable(L, Index);").
  880.    
  881. :- pragma inline(lua_istable/2).
  882.  
  883. :- pragma foreign_proc("C", lua_islightuserdata(L::in, Index::in),
  884.     [promise_semipure, will_not_call_mercury],
  885.     "SUCCESS_INDICATOR = lua_islightuserdata(L, Index);").
  886.    
  887. :- pragma inline(lua_islightuserdata/2).
  888.    
  889. :- pragma foreign_proc("C", lua_isboolean(L::in, Index::in),
  890.     [promise_semipure, will_not_call_mercury],
  891.     "SUCCESS_INDICATOR = lua_isboolean(L, Index);").
  892.    
  893. :- pragma inline(lua_isboolean/2).
  894.    
  895. :- pragma foreign_proc("C", lua_isfunction(L::in, Index::in),
  896.     [promise_semipure, will_not_call_mercury],
  897.     "SUCCESS_INDICATOR = lua_isfunction(L, Index);").
  898.  
  899. :- pragma inline(lua_isfunction/2).
  900.  
  901. :- pragma foreign_proc("C", lua_iscfunction(L::in, Index::in),
  902.     [promise_semipure, will_not_call_mercury],
  903.     "SUCCESS_INDICATOR = lua_iscfunction(L, Index);").
  904.    
  905. :- pragma inline(lua_iscfunction/2).
  906.  
  907.  
  908. %-----------------------------------------------------------------------------%
  909.  
  910. :- pragma foreign_proc("C", lua_tonumber(L::in, Index::in) = (V::out),
  911.     [promise_semipure, will_not_call_mercury],
  912.     "V = lua_tonumber(L, Index);").
  913.    
  914. :- pragma inline(lua_tonumber/2).
  915.  
  916. :- pragma foreign_proc("C", lua_tostring(L::in, Index::in) = (V::out),
  917.     [promise_semipure, will_not_call_mercury], "
  918.     V = MR_copy_string(lua_tostring(L, Index));
  919. ").
  920.  
  921. :- pragma foreign_proc("C", lua_tointeger(L::in, Index::in) = (V::out),
  922.     [promise_semipure, will_not_call_mercury],
  923.     "V = lua_tointeger(L, Index);").
  924.    
  925. :- pragma inline(lua_tointeger/2).
  926.  
  927. :- pragma foreign_proc("C", lua_tothread(L::in, Index::in) = (V::out),
  928.     [promise_semipure, will_not_call_mercury],
  929.     "V = lua_tothread(L, Index);").
  930.  
  931. :- pragma inline(lua_tothread/2).
  932.    
  933. lua_touserdata(L, Index) = U :-
  934.     semipure lua_ismruserdata(L, Index) ->
  935.         semipure U = lua_tomruserdata(L, Index)
  936.     ;
  937.         semipure C = lua_tocuserdata(L, Index),
  938.         U = univ(C).
  939.  
  940. :- semipure func lua_tomruserdata(lua, index) = univ.
  941.    
  942. :- pragma foreign_proc("C", lua_tomruserdata(L::in, Index::in) = (V::out),
  943.     [promise_semipure, will_not_call_mercury],
  944.     "V = **(MR_Word **)lua_touserdata(L, Index);").
  945.    
  946. :- pragma inline(lua_touserdata/2).
  947.    
  948. :- pragma foreign_proc("C", lua_tocuserdata(L::in, Index::in) = (V::out),
  949.     [promise_semipure, will_not_call_mercury],
  950.     "V = (size_t)lua_touserdata(L, Index);").
  951.    
  952. :- pragma inline(lua_tocuserdata/2).
  953.  
  954. :- pragma foreign_proc("C", lua_toboolean(L::in, Index::in) = (V::out),
  955.     [promise_semipure, will_not_call_mercury],
  956.     "V = lua_toboolean(L, Index) ? MR_YES : MR_NO;").
  957.        
  958. :- pragma inline(lua_toboolean/2).
  959.        
  960. :- pragma foreign_proc("C", lua_tocfunction(L::in, Index::in) = (V::out),
  961.     [promise_semipure, will_not_call_mercury],
  962.     "V = lua_tocfunction(L, Index);").
  963.    
  964. :- pragma inline(lua_tocfunction/2).
  965.  
  966. :- pragma foreign_proc("C", lua_toref(L::in, Index::in) = (V::out),
  967.     [promise_semipure, will_not_call_mercury],
  968.     "V = (luaMR_Ref)luaMR_newref(L, Index);").
  969.    
  970. :- pragma inline(lua_toref/2).
  971.  
  972.  
  973. %-----------------------------------------------------------------------------%
  974.  
  975. :- pragma foreign_proc("C", lua_pushnumber(L::in, V::in),
  976.     [will_not_call_mercury],
  977.     "lua_pushnumber(L, V);").
  978.    
  979. :- pragma inline(lua_pushnumber/2).
  980.  
  981. :- pragma foreign_proc("C", lua_pushstring(L::in, V::in),
  982.     [will_not_call_mercury],
  983.     "lua_pushstring(L, V);").
  984.    
  985. :- pragma inline(lua_pushstring/2).
  986.  
  987. :- pragma foreign_proc("C", lua_pushinteger(L::in, V::in),
  988.     [will_not_call_mercury],
  989.     "lua_pushinteger(L, V);").
  990.    
  991. :- pragma inline(lua_pushinteger/2).
  992.  
  993. :- pragma foreign_proc("C", lua_pushthread(L::in),
  994.     [will_not_call_mercury],
  995.     "lua_pushthread(L);").
  996.    
  997. :- pragma inline(lua_pushthread/1).
  998.  
  999. :- pragma foreign_proc("C", lua_pushthread(L::in) = (Main::out),
  1000.     [will_not_call_mercury], "
  1001.     Main = lua_pushthread(L) ? MR_YES : MR_NO;").
  1002.  
  1003. :- pragma inline(lua_pushthread/1).
  1004.  
  1005. :- pragma foreign_proc("C", lua_pushnil(L::in),
  1006.     [will_not_call_mercury],
  1007.     "lua_pushnil(L);").
  1008.    
  1009. :- pragma inline(lua_pushnil/1).
  1010.  
  1011. lua_pushuserdata(L, V) :-
  1012.     impure lua_pushuniv(L, univ(V)).
  1013.    
  1014. :- pragma inline(lua_pushuserdata/2).
  1015.  
  1016. :- pragma foreign_proc("C", lua_pushuniv(L::in, V::in),
  1017.     [will_not_call_mercury], "
  1018.     MR_Word * mr_ptr = luaMR_new(V);
  1019.     MR_Word ** lua_ptr = lua_newuserdata(L, sizeof(MR_Word **));
  1020.     *lua_ptr = mr_ptr;
  1021.     luaMR_set_userdata_metatable(L, -1);
  1022.     ").
  1023.    
  1024.  
  1025. :- pragma foreign_proc("C", lua_pushlightuserdata(L::in, V::in),
  1026.     [will_not_call_mercury],
  1027.     "lua_pushlightuserdata(L, (void *)V);").
  1028.    
  1029. :- pragma inline(lua_pushlightuserdata/2).
  1030.    
  1031. :- pragma foreign_proc("C", lua_pushboolean(L::in, V::in),
  1032.     [will_not_call_mercury],
  1033.     "lua_pushboolean(L, V == MR_YES ? 1 : 0);").
  1034.    
  1035. :- pragma inline(lua_pushboolean/2).
  1036.  
  1037. lua_pushfunc(L, V) :-
  1038.     impure lua_pushuserdata(L, func_udata(V)),
  1039.     impure lua_pushcclosure(L, mr_call_ptr, 1).
  1040.    
  1041.  
  1042. :- pragma foreign_proc("C", lua_pushcfunction(L::in, V::in),
  1043.     [will_not_call_mercury],
  1044.     "lua_pushcfunction(L, V);").
  1045.    
  1046. :- pragma inline(lua_pushcfunction/2).
  1047.    
  1048. :- pragma foreign_proc("C", lua_pushcclosure(L::in, V::in, Up::in),
  1049.     [will_not_call_mercury],
  1050.     "lua_pushcclosure(L, V, Up);").
  1051.    
  1052. :- pragma inline(lua_pushcclosure/3).
  1053.  
  1054. :- pragma foreign_proc("C", lua_pushref(L::in, V::in),
  1055.     [will_not_call_mercury],
  1056.     "luaMR_pushref(L, V);").
  1057.    
  1058. :- pragma inline(lua_pushref/2).
  1059.  
  1060. %-----------------------------------------------------------------------------%
  1061.  
  1062. :- impure pred set_userdata_metatable(lua::in, index::in) is det.
  1063.  
  1064. :- pragma foreign_proc("C", set_userdata_metatable(L::in, I::in),
  1065.     [will_not_call_mercury], "luaMR_set_userdata_metatable(L, I);").
  1066.  
  1067. :- pragma inline(set_userdata_metatable/2).
  1068.  
  1069. :- pragma foreign_decl("C", "
  1070. void luaMR_set_userdata_metatable(lua_State *, int);
  1071. ").
  1072.  
  1073. :- pragma foreign_code("C", "
  1074.  
  1075. void luaMR_set_userdata_metatable(lua_State * L, int I) {
  1076.     lua_pushvalue(L, I);
  1077.    
  1078.     if(!lua_getmetatable(L, -1))
  1079.         lua_newtable(L);
  1080.    
  1081.    
  1082.    
  1083.     lua_pushstring(L, LUA_MR_USERDATA);
  1084.     lua_pushboolean(L, 1);
  1085.     lua_rawset(L, -3);
  1086.    
  1087.     lua_pushstring(L, ""__GC"");
  1088.     lua_pushcfunction(L, (lua_CFunction)luaMR_free);
  1089.     lua_rawset(L, -3);
  1090.  
  1091.     lua_pushstring(L, ""__tostring"");
  1092.     lua_pushcfunction(L, (lua_CFunction)luaMR_tostring);
  1093.     lua_rawset(L, -3);
  1094.  
  1095.     lua_setmetatable(L, -2);
  1096.        
  1097.     lua_pop(L, 1);
  1098. }
  1099. ").
  1100.  
  1101.  
  1102. %-----------------------------------------------------------------------------%
  1103. %-----------------------------------------------------------------------------%
RAW Paste Data