├── .gitignore ├── LICENSE ├── Mercury.options ├── README.md ├── apollo.api.m ├── apollo.init ├── apollo.m ├── apollo.state.m ├── template.m ├── test.m ├── trail.m └── util.m /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | *.err 3 | Mercury/ 4 | .idea/ 5 | .mps 6 | *.date3 7 | *.int3 8 | *.module_dep 9 | *.mh 10 | *.c_date 11 | *.date0 12 | *.date 13 | *.exe 14 | *.exe 15 | *.a 16 | *.init 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | Lua implemented in Mercury 294 | Copyright (C) 2013 C4Cypher 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License along 307 | with this program; if not, write to the Free Software Foundation, Inc., 308 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 309 | 310 | Also add information on how to contact you by electronic and paper mail. 311 | 312 | If the program is interactive, make it output a short notice like this 313 | when it starts in an interactive mode: 314 | 315 | Gnomovision version 69, Copyright (C) year name of author 316 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 317 | This is free software, and you are welcome to redistribute it 318 | under certain conditions; type `show c' for details. 319 | 320 | The hypothetical commands `show w' and `show c' should show the appropriate 321 | parts of the General Public License. Of course, the commands you use may 322 | be called something other than `show w' and `show c'; they could even be 323 | mouse-clicks or menu items--whatever suits your program. 324 | 325 | You should also get your employer (if you work as a programmer) or your 326 | school, if any, to sign a "copyright disclaimer" for the program, if 327 | necessary. Here is a sample; alter the names: 328 | 329 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 330 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 331 | 332 | {signature of Ty Coon}, 1 April 1989 333 | Ty Coon, President of Vice 334 | 335 | This General Public License does not permit incorporating your program into 336 | proprietary programs. If your program is a subroutine library, you may 337 | consider it more useful to permit linking proprietary applications with the 338 | library. If this is what you want to do, use the GNU Lesser General 339 | Public License instead of this License. 340 | -------------------------------------------------------------------------------- /Mercury.options: -------------------------------------------------------------------------------- 1 | #-----------------------------------------------------------------------------# 2 | # Copyright (C) 2002, 2004-2011 The University of Melbourne. 3 | # This file may only be copied under the terms of the GNU General 4 | # Public License - see the file COPYING in the Mercury distribution. 5 | #-----------------------------------------------------------------------------# 6 | # Mercury.options - module-specific flags for Mmake and `mmc --make'. 7 | #-----------------------------------------------------------------------------# 8 | 9 | # MCFLAGS += --flag 10 | # MCFLAGS-module += --flag 11 | 12 | MAIN_TARGET = test.exe 13 | 14 | # Debugging Flags 15 | MCFLAGS += --debug --stack-segments 16 | MCFLAGS += --target-debug 17 | MGNUCFLAGS += --c-debug 18 | 19 | MCFLAGS += --intermodule-optimization 20 | MCFLAGS += --no-inform-inferred 21 | MCFLAGS += --no-warn-det-decls-too-lax 22 | MCFLAGS += --no-warn-inferred-erroneous 23 | MCFLAGS += --no-warn-unresolved-polymorphism 24 | MCFLAGS += --use-trail 25 | MCFLAGS += --trail-segments 26 | MCFLAGS += --libgrades-exclude java 27 | MCFLAGS += --libgrades-exclude csharp 28 | MCFLAGS += --libgrades-include trseg 29 | 30 | # Include the Lua header 31 | CFLAGS += -I/usr/include/lua5.3 32 | 33 | # For Fun 34 | #MCFLAGS += --auto-comments 35 | 36 | #MCFLAGS += --use-grade-subdirs 37 | 38 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Apollo-lander 2 | ============= 3 | 4 | Mercury is a purely declarative logic programming language. It is related to 5 | both Prolog and Haskell.[1] It features a strong, static, polymorphic 6 | type system, as well as a strong mode and determinism system. 7 | 8 | Apollo, the ancient Greek name for the planet Mercury, when observed just before 9 | dawn as a morning star. 10 | 11 | The Apollo spacecraft was composed of three parts designed to accomplish the 12 | American Apollo program's goal of landing astronauts on the Moon by the end of 13 | the 1960s and returning them safely to Earth. 14 | 15 | Lua - A lightweight programming language with dynamic typing. 16 | From the Portuguese lua (“moon”). The inventors of the language were Brazilian. 17 | 18 | ============= 19 | 20 | If you are reading this, you should no doubt be aware that Mercury is a 21 | strict language. This is not merely about having a strict static type 22 | or mode system. Mercury was designed with a very specific set of semantics 23 | in mind. 24 | 25 | Mercury is intended to be a purely declarative language, without 26 | side-effects, and the Melbourne Mercury Compiler was designed specifically 27 | to optimize code written with those strict, declarative semantics in mind. 28 | While the language does allow you to deviate from those semantics, there 29 | is a price to be paid in efficiency and ease-of use. To do so is generally 30 | considered to be a 'bad idea'. 31 | 32 | In contrast, the Lua programming language is known for flexibility, 33 | extendability and for ease of code customization on the fly. Using syntax 34 | influenced by Ada and Eiffel, and borrowing a few functional programming 35 | features from Lisp, Lua is simple, lightweight and easy to understand. 36 | 37 | One of Lua's most notable features is it's extendability. There are a 38 | multitude of ways to extend Lua's syntax and modify it's behavior, 39 | allowing one to define and use Lua with their own semantics, tailored 40 | to the programmer's needs. 41 | This, coupled with a similarly simple stack based C API, makes Lua a very 42 | popular choice for embedding in or binding to foreign languages and 43 | environments. 44 | 45 | For a Mercury programmer, to attempt to embed Lua in Mercury might seem 46 | counter-intuitive (if not outright insane). Trying to work around 47 | Lua's dynamic, impure and unpredictable nature would run counter to 48 | Mercury's strengths and would be a nightmare to implement. 49 | 50 | At the same time, the way Lua's C API is implemented, if Lua were to load 51 | and invoke exported Mercury predicates and functions from a dynamic library, 52 | Mercury would be able to interact with the calling Lua state and it's 53 | instantiated variables as immutable values and data structures in a manner 54 | that preserves Mercury's pure declarative semantics. Furthermore, 55 | synergies with Lua's C API and language features would allow Mercury code 56 | to define methods for Lua to interact with Mercury values passed to Lua as 57 | if they were native Lua objects. 58 | 59 | This would allow Lua programmers the ability to take advantage of the speed 60 | and stability of compiled Mercury modules. It would also make it easier 61 | to embed Mercury in foreign code, and bind Mercury to foreign libraries and 62 | languages. 63 | 64 | For these reasons, this module is intended to provide a simple way to pass 65 | both data and procedure between Mercury 66 | and Lua in an efficient and seamless manner. 67 | 68 | ============= 69 | 70 | apollo.m 71 | -------- 72 | 73 | Top level language binding written to facilitate Mercury style IO passing to manipulate Lua 74 | variables, values and the Lua state 75 | 76 | apollo.api.m 77 | ---- 78 | 79 | Primitive (semipure and impure) bindings directly to the Lua C api. 80 | It is advised that this module not be directly used unless one understand the workings 81 | of the Lua Stack and the Lua C api. 82 | 83 | 84 | apollo.state.m 85 | -------------- 86 | 87 | Facilitates types and methods to facilitate handling the Lua state as if it were a 88 | Mercury style IO variable, including the possibility for backtracking certain 89 | changes to the Lua state 90 | 91 | trail.m 92 | ------- 93 | 94 | Methods to further facilitate trailing and backtracking via the Lua state 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | -------------------------------------------------------------------------------- /apollo.api.m: -------------------------------------------------------------------------------- 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: apollo.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 apollo.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 | % Pass an int as an index. 87 | :- func index(int) = index. 88 | :- mode index(in) = out is det. 89 | :- mode index(out) = in is det. 90 | 91 | % Pass a int as an absolute (positive) index 92 | :- semipure func absolute(int, lua) = index. 93 | :- mode absolute(in, in) = out is det. 94 | :- mode absolute(out, in) = in is det. 95 | 96 | 97 | :- semipure pred lua_posindex(index, lua). 98 | :- mode lua_posindex(out, in) is nondet. 99 | :- mode lua_posindex(out, in) is cc_nondet. 100 | 101 | %-----------------------------------------------------------------------------% 102 | % 103 | % Stack Manipulation 104 | % 105 | 106 | % The index at the top of the stack. 107 | :- semipure func lua_gettop(lua) = int. 108 | 109 | % settop(N, L) :: [... X, Y, Z] -> [... X, Y] 110 | % N N 111 | % settop(N + 2, L) :: [... X] -> [... X, nil, nil] 112 | % N N N+1 N+2 113 | % 114 | :- impure pred lua_settop(int::in, lua::in) is det. 115 | 116 | % Allocate free space on the stack if needed, fail if it cannot 117 | :- semipure pred lua_checkstack(int::in, lua::in) is semidet. 118 | 119 | % Throw an error if checkstack fails to allocate 120 | :- semipure pred det_checkstack(int::in, lua::in) is det. 121 | 122 | % Directly push values from a different stack index 123 | :- impure pred lua_pushvalue(index::in, lua::in) is det. 124 | 125 | % Pop a number of values off the stack. 126 | :- impure pred lua_pop(int::in, lua::in) is det. 127 | 128 | % Note: Use of lua_remove and lua_insert is highly discouraged when used with 129 | % this library, given that said operations impurely re-arrange the Lua stack 130 | % in a manner that ignores restrictions that Mercury needs to interact with 131 | % it purely. Furthermore, the indexes provided to the following procedures 132 | % MUST be valid indexes on the stack, not pseudo-indexes such as 133 | % registryindex or globalindex. 134 | 135 | % Remove a value from the stack at a given index, shifting the elments 136 | % above it down(dangerous) 137 | % 138 | :- impure pred lua_remove(index::in, lua::in) is det. 139 | 140 | % Pop a value from the top of the stack and use it to replace the 141 | % value at the given stack index, without disturbing the rest of the 142 | % stack. 143 | :- impure pred lua_replace(index::in, lua::in) is det. 144 | 145 | % Pop a value from the top of the stack, and insert it at the 146 | % given stack index, shifting elements up. 147 | :- impure pred lua_insert(index::in, lua::in) is det. 148 | 149 | %-----------------------------------------------------------------------------% 150 | % 151 | % Values and vars 152 | % 153 | 154 | % Push a apollo.value onto the Lua stack 155 | :- impure pred push_value(value::in, lua::in) is det. 156 | 157 | % Push a list of values onto the stack, and return the number of values 158 | :- impure pred push_values(values::in, int::out, lua::in) is det. 159 | 160 | :- impure func push_values(values, lua) = int is det. 161 | 162 | % Push an apollo.var onto the stack 163 | :- impure pred push_var(var::in, lua::in) is det. 164 | 165 | % Push a list of variables onto the stack, and return the number of variabls 166 | :- impure pred push_vars(vars::in, int::out, lua::in) is det. 167 | 168 | :- impure func push_vars(vars, lua) = int is det. 169 | 170 | % Retreive the value at a given index. Tables and Functions will be 171 | % converted to refs. 172 | :- semipure func to_value(index, lua) = value. 173 | 174 | % Retreive the first N values on the top of the stack in a list 175 | :- semipure pred to_values(int, values, lua). 176 | :- mode to_values(in, out, in) is det. 177 | 178 | :- semipure func to_values(int, lua) = values is det. 179 | 180 | % Retreive the value at the given index. Tables and functions will be 181 | % passed by local stack index. 182 | :- semipure func local_value(index, lua) = value. 183 | 184 | % A given var is valid. 185 | :- semipure pred valid_var(var, lua). 186 | :- mode valid_var(in, in) is semidet. 187 | 188 | % table_value(Table, Key, Value, L) 189 | % all non-nil values assigned to a table. 190 | % fails if Table is not a table. 191 | % 192 | :- semipure pred table_value(var, value, value, lua). 193 | :- mode table_value(in, out, out, in) is nondet. 194 | 195 | % Return the lua_type of a var 196 | :- semipure pred var_type(var::in, lua_type::out, lua::in) is det. 197 | :- semipure func var_type(var, lua) = lua_type. 198 | 199 | 200 | % Check to see if the values at two indexes are equal. 201 | :- semipure pred lua_rawequal(index::in, index::in, lua::in) is semidet. 202 | 203 | % Test equality on vars (no metamethods) 204 | :- semipure pred var_equal(var::in, var::in, lua::in) is semidet. 205 | 206 | % Test equality on values (no metamethods) 207 | :- semipure pred value_equal(value::in, value::in, lua::in) is semidet. 208 | 209 | %-----------------------------------------------------------------------------% 210 | % 211 | % Accessing and manipulating variables 212 | % 213 | 214 | 215 | % The Lua type of a value on the stack 216 | % 217 | :- semipure func lua_type(index, lua) = lua_type. 218 | 219 | % The Lua type of a stack value as a string 220 | % 221 | :- semipure func lua_typename(index, lua) = string. 222 | 223 | % Get calls will remove the key from the top of the table and replace it 224 | % with the value. 225 | % 226 | % Lua: v = t[k] 227 | % get(N, L) :: [... t, ... k] -> [... t, ... v] 228 | % N -1 N -1 229 | % 230 | % Set calls will remove both the key and the value from the top of the stack. 231 | % 232 | % Lua: t[k] = v 233 | % set(N, L) :: [... t, ... _, k, v] -> [... t, ... _] 234 | % N X Y Z N X 235 | 236 | 237 | % Access Lua tables without invoking metamethods 238 | % 239 | :- impure pred lua_rawget(index::in, lua::in) is det. 240 | :- impure pred lua_rawset(index::in, lua::in) is det. 241 | 242 | % Access the array portion of a Lua table without invoking metamethods 243 | % 244 | :- impure pred lua_rawgeti(index::in, int::in, lua::in) is det. 245 | :- impure pred lua_rawseti(index::in, int::in, lua::in) is det. 246 | 247 | % Access Lua tables, if Raw is yes, metamethod invocations are avoided, 248 | % but an error is thrown if Table is not actually a table. 249 | % 250 | :- impure pred lua_gettable(index::in, lua::in) is det. 251 | :- impure pred lua_settable(index::in, lua::in) is det. 252 | 253 | % Access a value from a table using a string key 254 | % 255 | :- impure pred lua_getfield(index::in, string::in, lua::in) is det. 256 | :- impure pred lua_setfield(index::in, string::in, lua::in) is det. 257 | 258 | % Access metatables, may cause undefined behavior if used on types 259 | % that do not have metatables. 260 | % 261 | :- impure pred lua_getmetatable(index::in, lua::in) is semidet. 262 | :- impure pred lua_setmetatable(index::in, lua::in) is det. 263 | 264 | % Create an empty table and push it onto the stack. 265 | % 266 | :- impure pred lua_newtable(lua::in) is det. 267 | 268 | % Pop a key from the top of the stack and push the key-value pair 269 | % corresponding to the 'next' value associated with the table at 270 | % the given index. 271 | % 272 | :- impure pred lua_next(index::in, lua::in) is semidet. 273 | 274 | %-----------------------------------------------------------------------------% 275 | % 276 | % The registry, and upvalues. 277 | % 278 | 279 | % Access the registry 280 | % 281 | :- impure pred lua_getregistry(string::in, lua::in) is det. 282 | :- impure pred lua_setregistry(string::in, lua::in) is det. 283 | 284 | % Access an upvalue 285 | % 286 | :- impure pred lua_getupvalue(int::in, lua::in) is semidet. 287 | :- impure pred lua_setupvalue(int::in, lua::in) is det. 288 | 289 | 290 | 291 | 292 | 293 | %-----------------------------------------------------------------------------% 294 | % 295 | % Function constructors, deconstructors, and calls 296 | % 297 | 298 | 299 | % Load a function from a string. 300 | :- impure func lua_loadstring(string, lua) = status is det. 301 | 302 | % lua_call(Args, Results, L) 303 | % lua_call(Args, L) = Results] 304 | % call a function 305 | :- impure pred lua_call(int::in, int::in, lua::in) is det. 306 | :- impure func lua_call(int, lua) = int. 307 | 308 | % lua_pcall(Args, Results, Error_handler, L) = Result. 309 | % lua_pcall(Args, Error_handler, L) = Result. 310 | % lua_pcall(Args, L) = Returned. 311 | % call a function with an error handler. If 312 | % no error handler is 313 | :- impure func lua_pcall(int, int, index, lua) = lua_result. 314 | :- impure func lua_pcall(int, index, lua) = lua_result. 315 | :- impure func lua_pcall(int, lua) = lua_result. 316 | 317 | 318 | % Utility function that returns the value Lua defines in C: LUA_MULTRET 319 | :- func multret = int. 320 | 321 | 322 | % Call a mercury function from C 323 | % 324 | :- impure func mr_call(lua) = int. 325 | 326 | 327 | % It is MUCH easier to pass a normal Mercury type to C and Lua than it is 328 | % to pass a higher order predicate value. 329 | % 330 | :- type func_udata ---> mr_func(mr_func). 331 | 332 | :- inst func_udata == bound(mr_func(mr_func)). 333 | :- mode pui == in(func_udata). 334 | :- mode puo == out(func_udata). 335 | 336 | :- func func_udata(mr_func) = func_udata. 337 | :- mode func_udata(mri) = puo is det. 338 | :- mode func_udata(mro) = pui is det. 339 | 340 | 341 | :- type lua_result 342 | ---> returned(int) 343 | ; returned_error(lua_error). 344 | 345 | % cpcall(CFunc, LUdataIn, L) = LUdataOut 346 | % 347 | % Protected C call in Lua, passing a pointer (or MR_Word) 348 | % as the only argument. 349 | % 350 | :- impure func lua_cpcall(c_function, c_pointer, lua) = c_pointer. 351 | 352 | % Throw an error from Mercury to Lua, passing the value on the stack 353 | % as the error value. 354 | % 355 | :- impure pred lua_error(lua::in) is erroneous. 356 | 357 | % Throw an error from Mercury to Lua, passing the given value 358 | % as the error value. 359 | % 360 | :- impure pred lua_error(T::in, lua::in) is erroneous. 361 | 362 | 363 | 364 | 365 | %-----------------------------------------------------------------------------% 366 | % 367 | % Utilites for the concrete Lua state. 368 | % 369 | 370 | % Create a fresh, new , initialized lua. 371 | % 372 | :- func lua_new = lua. 373 | 374 | 375 | % Destroy a lua 376 | % 377 | :- impure pred lua_close(lua::in) is det. 378 | 379 | 380 | % Return the Lua state's current status. 381 | % 382 | :- semipure func lua_status(lua) = status. 383 | 384 | 385 | :- type status 386 | ---> ready 387 | ; yield 388 | ; runtime_error 389 | ; syntax_error 390 | ; memory_error 391 | ; unhandled_error. 392 | 393 | %-----------------------------------------------------------------------------% 394 | %-----------------------------------------------------------------------------% 395 | % 396 | % Value passing 397 | % 398 | 399 | :- semipure pred lua_isnumber(index::in, lua::in) is semidet. 400 | :- semipure pred lua_isnil(index::in, lua::in) is semidet. 401 | :- semipure pred lua_isuserdata(index::in, lua::in) is semidet. 402 | :- semipure pred lua_ismruserdata(index::in, lua::in) is semidet. 403 | :- semipure pred lua_isinteger(index::in, lua::in) is semidet. 404 | :- semipure pred lua_islightuserdata(index::in, lua::in) is semidet. 405 | :- semipure pred lua_isstring(index::in, lua::in) is semidet. 406 | :- semipure pred lua_istable(index::in, lua::in) is semidet. 407 | :- semipure pred lua_isboolean(index::in, lua::in) is semidet. 408 | :- semipure pred lua_isthread(index::in, lua::in) is semidet. 409 | :- semipure pred lua_isfunction(index::in, lua::in) is semidet. 410 | :- semipure pred lua_iscfunction(index::in, lua::in) is semidet. 411 | 412 | :- semipure func lua_tonumber(index, lua) = float. 413 | :- semipure func lua_touserdata(index, lua) = univ. 414 | :- semipure func lua_tocuserdata(index, lua) = c_pointer. 415 | :- semipure func lua_tointeger(index, lua) = int. 416 | :- semipure func lua_tostring(index, lua) = string. 417 | :- semipure func lua_toboolean(index, lua) = bool. 418 | :- semipure func lua_tothread(index, lua) = lua. 419 | :- semipure func lua_tocfunction(index, lua) = c_function. 420 | :- semipure func lua_toref(index, lua) = ref. 421 | 422 | :- impure pred lua_pushnil(lua::in) is det. 423 | :- impure pred lua_pushnumber(float::in, lua::in) is det. 424 | :- impure pred lua_pushuserdata(T::in, lua::in) is det. 425 | :- impure pred lua_pushuniv(univ::in, lua::in) is det. 426 | :- impure pred lua_pushinteger(int::in, lua::in) is det. 427 | :- impure pred lua_pushlightuserdata(c_pointer::in, lua::in) is det. 428 | :- impure pred lua_pushstring(string::in, lua::in) is det. 429 | :- impure pred lua_pushboolean(bool::in, lua::in) is det. 430 | :- impure pred lua_pushthread(lua::in) is det. 431 | :- impure func lua_pushthread(lua) = bool. 432 | :- impure pred lua_pushpred(mr_func::mri, lua::in) is det. 433 | :- impure pred lua_pushcfunction(c_function::in, lua::in) is det. 434 | :- impure pred lua_pushcclosure(c_function::in, int::in, lua::in) is det. 435 | :- impure pred lua_pushref(ref::in, lua::in) is det. 436 | 437 | %-----------------------------------------------------------------------------% 438 | %-----------------------------------------------------------------------------% 439 | 440 | :- implementation. 441 | 442 | :- import_module require. 443 | :- import_module exception. 444 | :- import_module solutions. 445 | 446 | :- pragma foreign_import_module("C", apollo). 447 | 448 | :- pragma foreign_decl("C", " 449 | #include 450 | #include 451 | #include 452 | "). 453 | 454 | %-----------------------------------------------------------------------------% 455 | % 456 | % Stack indexes 457 | % 458 | 459 | 460 | 461 | :- pragma foreign_proc("C", registryindex = (I::out), 462 | [promise_pure, will_not_call_mercury], "I = LUA_REGISTRYINDEX;"). 463 | 464 | :- pragma inline(registryindex/0). 465 | 466 | :- pragma foreign_proc("C", globalindex = (I::out), 467 | [promise_pure, will_not_call_mercury], " 468 | #ifdef BEFORE_502 469 | I = LUA_GLOBALSINDEX; 470 | #else 471 | I = LUA_RIDX_GLOBALS; 472 | #endif 473 | "). 474 | 475 | 476 | :- pragma inline(globalindex/0). 477 | 478 | index(I) = I. 479 | 480 | :- pragma inline(index/1). 481 | 482 | :- pragma foreign_proc("C", absolute(I::in, L::in) = (A::out), 483 | [promise_semipure, will_not_call_mercury], " 484 | A = I > 0 ? I : lua_gettop(L) + 1 + I;"). 485 | 486 | :- pragma foreign_proc("C", absolute(I::out, L::in) = (A::in), 487 | [promise_semipure, will_not_call_mercury], " 488 | I = A > 0 ? I : lua_gettop(L) + 1 + I;"). 489 | 490 | :- pragma inline(absolute/2). 491 | 492 | :- pragma foreign_decl("C", " 493 | int apollo_absolute(lua_State *, int);"). 494 | 495 | :- pragma foreign_code("C", " 496 | int apollo_absolute(lua_State * L, int I) { 497 | return I > 0 ? I : lua_gettop(L) + 1 + I; 498 | } 499 | "). 500 | 501 | 502 | %-----------------------------------------------------------------------------% 503 | % 504 | % Stack Manipulation 505 | % 506 | 507 | :- pragma foreign_proc("C", lua_gettop(L::in) = (Index::out), 508 | [promise_semipure, will_not_call_mercury], 509 | "Index = lua_gettop(L); "). 510 | 511 | :- pragma inline(lua_gettop/1). 512 | 513 | :- pragma foreign_proc("C", lua_settop(Index::in, L::in), 514 | [will_not_call_mercury], 515 | "lua_settop(L, Index);"). 516 | 517 | :- pragma inline(lua_settop/2). 518 | 519 | :- pragma foreign_proc("C", lua_checkstack(Free::in, L::in), 520 | [will_not_call_mercury, promise_semipure], 521 | "SUCCESS_INDICATOR = lua_checkstack(L, Free);"). 522 | 523 | :- pragma inline(lua_checkstack/2). 524 | 525 | det_checkstack(Free, L) :- 526 | semipure lua_checkstack(Free, L) -> 527 | true 528 | ; 529 | throw(lua_error(memory_error, "Checkstack failed")). 530 | 531 | :- pragma foreign_proc("C", lua_pushvalue(I::in, L::in), 532 | [will_not_call_mercury], "lua_pushvalue(L, I);"). 533 | 534 | :- pragma inline(lua_pushvalue/2). 535 | 536 | :- pragma foreign_proc("C", lua_pop(Num::in, L::in), 537 | [will_not_call_mercury], "lua_pop(L, Num);"). 538 | 539 | :- pragma inline(lua_pop/2). 540 | 541 | :- pragma foreign_proc("C", lua_remove(Index::in, L::in), 542 | [will_not_call_mercury], "lua_remove(L, Index);"). 543 | 544 | :- pragma inline(lua_remove/2). 545 | 546 | :- pragma foreign_proc("C", lua_replace(Index::in, L::in), 547 | [will_not_call_mercury], "lua_replace(L, Index);"). 548 | 549 | :- pragma inline(lua_replace/2). 550 | 551 | :- pragma foreign_proc("C", lua_insert(Index::in, L::in), 552 | [will_not_call_mercury], "lua_insert(L, Index);"). 553 | 554 | :- pragma inline(lua_insert/2). 555 | 556 | lua_posindex(I, L) :- 557 | semipure Top = lua_gettop(L), 558 | posindex2(Top, I). 559 | 560 | 561 | :- pred posindex2(int::in, int::out) is nondet. 562 | 563 | posindex2(Top, I) :- 564 | Top > 0, 565 | ( 566 | I = Top 567 | ; 568 | posindex2(Top - 1, I) 569 | ). 570 | 571 | %-----------------------------------------------------------------------------% 572 | % 573 | % Values and vars 574 | % 575 | 576 | push_value(V, L) :- 577 | require_complete_switch [V] 578 | ( V = nil(_), 579 | impure lua_pushnil(L) 580 | ; V = number(F), 581 | impure lua_pushnumber(F, L) 582 | ; V = integer(I), 583 | impure lua_pushinteger(I, L) 584 | ; V = boolean(B), 585 | impure lua_pushboolean(B, L) 586 | ; V = string(S), 587 | impure lua_pushstring(S, L) 588 | ; V = lightuserdata(P), 589 | impure lua_pushlightuserdata(P, L) 590 | ; V = thread(L2), 591 | (L2 = L -> impure lua_pushthread(L) 592 | ; error("Can only push the active thread onto the stack.") 593 | ) 594 | ; V = c_function(F), 595 | impure lua_pushcfunction(F, L) 596 | ; V = var(Var), 597 | impure push_var(Var, L) 598 | ; V = userdata(U), 599 | impure lua_pushuniv(U, L) 600 | ; V = lua_error(E), 601 | impure lua_error(E, L) 602 | ). 603 | 604 | push_var(V, L) :- 605 | require_complete_switch [V] 606 | ( V = local(I), impure lua_pushvalue(I, L) 607 | ; V = index(Val, Table), 608 | ( Val = nil(_) -> impure lua_pushnil(L) 609 | ; impure push_var(Table, L), semipure lua_isnil(-1, L) -> 610 | throw(lua_error( 611 | runtime_error, "attempt to index var " 612 | ++ string.string(Table) ++ 613 | " (a nil value).")) 614 | ; 615 | impure push_value(Val, L), 616 | impure lua_rawget(-2, L), 617 | impure lua_remove(-2, L) 618 | ) 619 | ; V = meta(Table), 620 | impure push_var(Table, L), 621 | ( impure lua_getmetatable(-1, L) -> 622 | impure lua_remove(-2, L) 623 | ; 624 | impure lua_pop(1, L), 625 | impure lua_pushnil(L) 626 | ) 627 | ; V = ref(R), impure lua_pushref(R, L) 628 | ; V = global(S), 629 | impure lua_pushvalue(globalindex, L), 630 | impure lua_pushstring(S, L), 631 | impure lua_rawget(-2, L), 632 | impure lua_remove(-2, L) 633 | ; V = invalid(S), 634 | throw(lua_error(runtime_error, $module ++ "." ++ $pred ++ 635 | " attempted to push invalid var: " ++ S)) 636 | ). 637 | 638 | % Push a list of values onto the stack, and return the number of values 639 | %:- impure pred push_values(values::in, int::out, lua::in) is det. 640 | % 641 | %:- impure func push_vars(values, lua) = int is det. 642 | 643 | push_values(Values, Count, L) :- 644 | Values = [] -> Count = 0 ; 645 | Values = [ Value | Rest ] -> 646 | impure push_value(Value, L), 647 | impure push_values(Rest, CountRest, L), 648 | Count = CountRest + 1; 649 | unexpected($module, "invalid list of variables)"). 650 | 651 | push_values(Values, L) = Count :- impure push_values(Values, Count, L). 652 | 653 | % Push a list of variables onto the stack, and return the number of variabls 654 | %:- impure pred push_vars(vars::in, int::out, lua::in) is det. 655 | % 656 | %:- impure func push_vars(vars, lua) = int is det. 657 | 658 | push_vars(Vars, Count, L) :- 659 | Vars = [] -> Count = 0 ; 660 | Vars = [ Var | Rest ] -> 661 | impure push_var(Var, L), 662 | impure push_vars(Rest, CountRest, L), 663 | Count = CountRest + 1 ; 664 | unexpected($module, "invalid list of variables)"). 665 | 666 | push_vars(Vars, L) = Count :- impure push_vars(Vars, Count, L). 667 | 668 | to_value(I, L) = V :- 669 | semipure to_value(I, to_refvar, L) = V. 670 | 671 | local_value(I, L) = V :- 672 | semipure to_value(I, to_localvar, L) = V. 673 | 674 | 675 | 676 | :- semipure func to_value(index, (semipure func(index, lua) = var), lua) 677 | = value. 678 | 679 | to_value(I0, ToVar, L) = V :- 680 | semipure I = absolute(I0, L), 681 | semipure Type = lua_type(I, L), 682 | require_complete_switch [Type] 683 | ( Type = none, 684 | unexpected($module, $pred, "Value at given index had no type: ") 685 | ; Type = nil_type, 686 | V = nil(nil) 687 | ; Type = number_type, 688 | semipure F = lua_tonumber(I, L), 689 | V = number(F) 690 | ; Type = boolean_type, 691 | semipure B = lua_toboolean(I, L), 692 | V = boolean(B) 693 | ; Type = string_type, 694 | semipure S = lua_tostring(I, L), 695 | V = string(S) 696 | ; Type = lightuserdata_type, 697 | semipure C = lua_tocuserdata(I, L), 698 | V = lightuserdata(C) 699 | ; Type = function_type, 700 | ( semipure lua_iscfunction(I, L) -> 701 | semipure F = lua_tocfunction(I, L), 702 | V = c_function(F) 703 | ; semipure Var = semipure_apply(ToVar, I, L), 704 | V = var(Var) 705 | ) 706 | ; Type = table_type, 707 | semipure T = semipure_apply(ToVar, I, L), 708 | V = var(T) 709 | ; Type = thread_type, 710 | semipure T = lua_tothread(I, L), 711 | V = thread(T) 712 | ; Type = userdata_type, 713 | semipure U = lua_touserdata(I, L), 714 | V = userdata(U) 715 | ). 716 | 717 | % Retreive the first N values on the top of the stack in a list 718 | %:- semipure pred to_values(int, values, lua). 719 | %:- mode to_values(in, out, in) is det. 720 | % 721 | %:- semipure func to_values(int, lua) = values is det. 722 | 723 | to_values(Number, Values, L) :- 724 | Number = 0 -> Values = [] ; 725 | semipure Index = absolute(-Number, L), 726 | semipure to_value(Index, L) = Val, 727 | semipure Rest = to_values(Number -1, L), 728 | Values = [ Val | Rest ]. 729 | 730 | to_values(Number, L) = Values :- semipure to_values(Number, Values, L). 731 | 732 | :- semipure func to_localvar(index, lua) = var. 733 | 734 | to_localvar(I, _) = V :- 735 | V = local(I), 736 | semipure semipure_true. 737 | 738 | :- semipure func to_refvar(index, lua) = var. 739 | 740 | to_refvar(I, L) = V :- 741 | semipure R = lua_toref(I, L), 742 | V = ref(R). 743 | 744 | 745 | :- pragma foreign_proc("C", lua_rawequal(Index1::in, Index2::in, L::in), 746 | [promise_semipure, will_not_call_mercury], 747 | "SUCCESS_INDICATOR = lua_rawequal(L, Index1, Index2);"). 748 | 749 | :- pragma inline(lua_rawequal/3). 750 | 751 | 752 | valid_var(V, L) :- 753 | require_complete_switch [V] 754 | ( V = local(Local), 755 | semipure Top = lua_gettop(L), 756 | ( Local < 0, Local >= -Top 757 | ; Local > 0, Local =< Top 758 | ) 759 | ; V = index(_, Table), 760 | semipure var_type(Table, table_type, L) 761 | ; V = meta(Var), 762 | not 763 | ( semipure var_type(Var, string_type, L) 764 | ; semipure var_type(Var, number_type, L) 765 | ; semipure var_type(Var, lightuserdata_type, L) 766 | ; semipure var_type(Var, nil_type, L) 767 | ) 768 | ; V = ref(_) 769 | ; V = global(_) 770 | ; V = invalid(_), fail 771 | ). 772 | 773 | 774 | table_value(Table, Key, Value, L) :- 775 | semipure det_checkstack(6, L), 776 | semipure var_type(Table, table_type, L), 777 | impure lua_newtable(L), % Memo set table 778 | impure push_var(Table, L), 779 | impure lua_pushboolean(yes, L), 780 | impure lua_rawset(-3, L), % Set the next value 781 | semipure Next = lua_toref(-1, L), 782 | impure lua_pop(1, L), 783 | semipure table_value2(Table, Key, Value, Next, L). 784 | 785 | :- pragma promise_semipure(table_value/4). 786 | 787 | :- semipure pred table_value2(var, value, value, ref, lua). 788 | :- mode table_value2(in, out, out, in, in) is nondet. 789 | 790 | table_value2(Table, Key, Value, Last, L) :- 791 | impure push_var(Table, L), % Table being iterated 792 | impure lua_pushref(Last, L), % Last key 793 | impure lua_next(-2, L) -> % Pop the last key and push the next pair 794 | % The stack should now look like [Table, Key, Value] 795 | ( 796 | semipure Key = to_value(-2, L), 797 | semipure Value = to_value(-1, L) 798 | ; 799 | semipure Next = lua_toref(-2, L), 800 | semipure table_value2(Table, Key, Value, Next, L) 801 | ), 802 | impure lua_pop(3, L) % Clear the stack 803 | ; impure lua_pop(1, L), % Clear the stack and fail 804 | fail. % There are no more pairs, 805 | 806 | 807 | :- pragma promise_semipure(table_value2/5). 808 | 809 | 810 | var_type(V, T, L) :- 811 | impure push_var(V, L), 812 | semipure T = lua_type(-1, L), 813 | impure lua_pop(1, L). 814 | 815 | :- pragma promise_semipure(var_type/3). 816 | 817 | 818 | var_type(V, L) = T :- semipure var_type(V, T, L). 819 | 820 | var_equal(V1, V2, L) :- 821 | impure push_var(V1, L), 822 | impure push_var(V2, L), 823 | semipure lua_rawequal(-1, -2, L) -> 824 | impure lua_pop(2, L) 825 | ; 826 | impure lua_pop(2, L), 827 | fail. 828 | 829 | :- pragma promise_semipure(var_equal/3). 830 | 831 | value_equal(V1, V2, L) :- 832 | impure push_value(V1, L), 833 | impure push_value(V2, L), 834 | semipure lua_rawequal(-1, -2, L) -> 835 | impure lua_pop(2, L) 836 | ; 837 | impure lua_pop(2, L), 838 | fail. 839 | 840 | :- pragma promise_semipure(value_equal/3). 841 | 842 | 843 | %-----------------------------------------------------------------------------% 844 | % 845 | % Accessing and manipulating variables 846 | % 847 | 848 | :- pragma foreign_proc("C", lua_type(Index::in, L::in) = (Type::out), 849 | [promise_semipure, will_not_call_mercury], 850 | "Type = lua_type(L, Index);"). 851 | 852 | :- pragma inline(lua_type/2). 853 | 854 | :- pragma foreign_proc("C", lua_typename(Index::in, L::in) = (Name::out), 855 | [promise_semipure, will_not_call_mercury], 856 | "Name = (char *)lua_typename(L, lua_type(L, Index));"). 857 | 858 | :- pragma inline(lua_typename/2). 859 | 860 | 861 | :- pragma foreign_proc("C", lua_rawget(I::in, L::in), 862 | [will_not_call_mercury], "lua_rawget(L, I);"). 863 | 864 | :- pragma inline(lua_rawget/2). 865 | 866 | :- pragma foreign_proc("C", lua_rawset(I::in, L::in), 867 | [will_not_call_mercury], "lua_rawset(L, I);"). 868 | 869 | :- pragma inline(lua_rawset/2). 870 | 871 | :- pragma foreign_proc("C", lua_rawgeti(I::in, N::in, L::in), 872 | [will_not_call_mercury], "lua_rawgeti(L, I, N);"). 873 | 874 | :- pragma inline(lua_rawgeti/3). 875 | 876 | :- pragma foreign_proc("C", lua_rawseti(I::in, N::in, L::in), 877 | [will_not_call_mercury], "lua_rawseti(L, I, N);"). 878 | 879 | :- pragma inline(lua_rawseti/3). 880 | 881 | :- pragma foreign_proc("C", lua_gettable(I::in, L::in), 882 | [may_call_mercury], "lua_gettable(L, I);"). 883 | 884 | :- pragma inline(lua_gettable/2). 885 | 886 | :- pragma foreign_proc("C", lua_settable(I::in, L::in), 887 | [may_call_mercury], "lua_settable(L, I);"). 888 | 889 | :- pragma inline(lua_settable/2). 890 | 891 | :- pragma foreign_proc("C", lua_getfield(I::in, K::in, L::in), 892 | [may_call_mercury], "lua_getfield(L, I, K);"). 893 | 894 | :- pragma inline(lua_getfield/3). 895 | 896 | :- pragma foreign_proc("C", lua_setfield(I::in, K::in, L::in), 897 | [will_not_call_mercury], "lua_setfield(L, I, K);"). 898 | 899 | :- pragma inline(lua_setfield/3). 900 | 901 | :- pragma foreign_proc("C", lua_getmetatable(I::in, L::in), 902 | [may_call_mercury], 903 | "SUCCESS_INDICATOR = lua_getmetatable(L, I);"). 904 | 905 | :- pragma inline(lua_getmetatable/2). 906 | 907 | :- pragma foreign_proc("C", lua_setmetatable(I0::in, L::in), 908 | [may_call_mercury], " 909 | int I = apollo_absolute(L, I0); 910 | lua_setmetatable(L, I); 911 | if(apollo_ismruserdata(I, L)) 912 | apollo_set_userdata_metatable(L, I); 913 | "). 914 | 915 | :- pragma foreign_proc("C", lua_newtable(L::in), 916 | [will_not_call_mercury], "lua_newtable(L);"). 917 | 918 | :- pragma inline(lua_newtable/1). 919 | 920 | :- pragma foreign_proc("C", lua_next(I::in, L::in), 921 | [may_call_mercury], "SUCCESS_INDICATOR = lua_next(L, I);"). 922 | 923 | %-----------------------------------------------------------------------------% 924 | % 925 | % The registry, and upvalues. 926 | % 927 | 928 | :- pragma foreign_proc("C", lua_getregistry(I::in, L::in), 929 | [will_not_call_mercury], "apollo_getregistry(L, I);"). 930 | 931 | :- pragma inline(lua_getregistry/2). 932 | 933 | :- pragma foreign_proc("C", lua_setregistry(I::in, L::in), 934 | [will_not_call_mercury], "apollo_setregistry(L, I);"). 935 | 936 | :- pragma inline(lua_setregistry/2). 937 | 938 | 939 | :- pragma foreign_proc("C", lua_getupvalue(I::in, L::in), 940 | [will_not_call_mercury], " 941 | SUCCESS_INDICATOR = apollo_getupvalue(L, I); 942 | "). 943 | 944 | :- pragma inline(lua_getupvalue/2). 945 | 946 | :- pragma foreign_proc("C", lua_setupvalue(I::in, L::in), 947 | [will_not_call_mercury], "apollo_setupvalue(L, I);"). 948 | 949 | :- pragma inline(lua_setupvalue/2). 950 | 951 | 952 | %-----------------------------------------------------------------------------% 953 | % 954 | % Function constructors, deconstructors, and calls 955 | % 956 | 957 | 958 | 959 | :- pragma foreign_proc("C", lua_loadstring(S::in, L::in) = (Success::out), 960 | [may_call_mercury], "Success = luaL_loadstring(L, S);"). 961 | 962 | :- pragma inline(lua_loadstring/2). 963 | 964 | :- pragma foreign_proc("C", lua_call(Args::in, Ret::in, L::in), 965 | [may_call_mercury], "lua_call(L, Args, Ret);"). 966 | 967 | :- pragma inline(lua_call/3). 968 | 969 | lua_call(A, L) = R :- 970 | semipure T1 = lua_gettop(L), 971 | S = T1 - A - 1, 972 | impure lua_call(A, multret, L), 973 | semipure T2 = lua_gettop(L), 974 | R = T2 - S. 975 | 976 | 977 | lua_pcall(A, R, E, L) = Result :- 978 | semipure T1 = lua_gettop(L), 979 | S = T1 - A - 1, 980 | impure Error = lua_pcall2(A, R, E, L), 981 | ( Error = no_error -> 982 | semipure T2 = lua_gettop(L), 983 | Result = returned(T2 - S) 984 | ; 985 | semipure Message = lua_tostring(-1, L), 986 | impure lua_pop(1, L), 987 | Result = returned_error(lua_error(Error, Message)) 988 | ). 989 | 990 | :- impure func lua_pcall2(int, int, index, lua) = error_type. 991 | 992 | :- pragma foreign_proc("C", lua_pcall2(Args::in, Ret::in, Err::in, L::in) 993 | = (Result::out), 994 | [may_call_mercury], " Result = lua_pcall(L, Args, Ret, Err);"). 995 | 996 | %:- pragma inline(lua_pcall/4). 997 | 998 | lua_pcall(A, E, L) = R :- 999 | impure R = lua_pcall(A, multret, E, L). 1000 | 1001 | lua_pcall(A, L) = R :- 1002 | impure R = lua_pcall(A, 0, L). 1003 | 1004 | :- pragma foreign_proc("C", lua_cpcall(Func::in, Ptr::in, L::in) = (R::out), 1005 | [may_call_mercury], " 1006 | R = lua_cpcall(L, Func, (void *)Ptr); 1007 | "). 1008 | 1009 | 1010 | 1011 | 1012 | :- pragma foreign_proc("C", multret = (M::out), 1013 | [promise_pure, will_not_call_mercury], "M = LUA_MULTRET;"). 1014 | 1015 | :- pragma inline(multret/0). 1016 | 1017 | 1018 | mr_call(L) = R :- 1019 | promise_equivalent_solutions [E] (try(mr_callpred(L), E)), 1020 | require_complete_switch [E] 1021 | ( E = succeeded(R) 1022 | ; E = failed, 1023 | impure lua_pushboolean(no, L), 1024 | R = 1 1025 | ; E = exception(Ex), 1026 | impure lua_pushnil(L), 1027 | impure lua_pushuserdata(Ex, L), 1028 | R = 2 1029 | ). 1030 | 1031 | :- pred mr_callpred(lua::in, int::out) is semidet. 1032 | 1033 | mr_callpred(L, R) :- 1034 | impure lua_getupvalue(1, L), 1035 | semipure lua_touserdata(-1, L) = U, 1036 | U = univ(PU:func_udata), 1037 | PU = func_udata(F) -> 1038 | impure impure_apply(F, L) = R 1039 | ; 1040 | error( 1041 | "Called Mercury function without valid func upvalue."). 1042 | 1043 | :- pragma promise_pure(mr_callpred/2). 1044 | 1045 | :- pragma foreign_export("C", mr_call(in) = out, "apollo_call"). 1046 | 1047 | :- func mr_call_ptr = c_function. 1048 | 1049 | :- pragma foreign_proc("C", mr_call_ptr = (F::out), 1050 | [promise_pure, will_not_call_mercury], "F = (lua_CFunction)apollo_call;"). 1051 | 1052 | :- pragma foreign_proc("C", lua_error(L::in), 1053 | [may_call_mercury],"lua_error(L);"). 1054 | 1055 | :- pragma inline(lua_error/1). 1056 | 1057 | lua_error(T, L) :- 1058 | impure lua_pushuserdata(T, L), 1059 | impure lua_error(L). 1060 | 1061 | 1062 | % It is MUCH easier to pass a normal Mercury type to C and Lua than it is 1063 | % to pass a higher order predicate value. 1064 | % 1065 | %:- type func_udata ---> mr_func(lua_func). 1066 | 1067 | %:- inst func_udata == mr_func(mr_func). 1068 | %:- mode pui = in(func_udata). 1069 | %:- mode puo = out(func_udata). 1070 | 1071 | %:- func func_udata(mr_func) = func_udata. 1072 | %:- mode func_udata(mri) = puo is det. 1073 | %:- mode func_udata(mro) = pui is det. 1074 | 1075 | 1076 | func_udata(F) = U :- U = mr_func(F). 1077 | 1078 | %:- pragma promise_pure(func_udata/1). 1079 | 1080 | 1081 | 1082 | %-----------------------------------------------------------------------------% 1083 | % 1084 | % Utilites for the concrete Lua state. 1085 | % 1086 | 1087 | 1088 | 1089 | :- func return_nil = nil. 1090 | 1091 | return_nil = nil. 1092 | 1093 | :- pragma inline(return_nil/0). 1094 | 1095 | :- pragma foreign_export("C", return_nil = out, "apollo_nil"). 1096 | 1097 | :- pragma foreign_proc("C", lua_new = (L::out), 1098 | [promise_pure, will_not_call_mercury], " 1099 | void * ptr = MR_malloc(sizeof(ptr)); 1100 | L = lua_newstate((lua_Alloc)apollo_alloc, ptr); 1101 | luaL_openlibs(L); 1102 | apollo_init(L); 1103 | "). 1104 | 1105 | :- pragma foreign_decl("C", " 1106 | void * apollo_alloc(void *, void *, size_t, size_t);"). 1107 | 1108 | :- pragma foreign_code("C", " 1109 | void * apollo_alloc(void * ud, void * ptr, 1110 | size_t osize, size_t nsize) { 1111 | (void)ud; 1112 | if(nsize == 0) { 1113 | if(osize == 0) 1114 | return NULL; 1115 | else 1116 | MR_GC_free(ptr); 1117 | return NULL; 1118 | } else { 1119 | if(osize == 0) { 1120 | ptr = MR_GC_malloc(nsize); 1121 | return ptr; 1122 | } else { 1123 | ptr = MR_GC_realloc(ptr,nsize); 1124 | return ptr; 1125 | } 1126 | } 1127 | } 1128 | "). 1129 | 1130 | 1131 | :- pragma inline(lua_new/0). 1132 | 1133 | 1134 | :- pragma foreign_proc("C", lua_close(L::in), 1135 | [may_call_mercury], "lua_close(L);"). 1136 | 1137 | :- pragma foreign_proc("C", lua_status(L::in) = (S::out), 1138 | [promise_semipure, will_not_call_mercury], "S = lua_status(L);"). 1139 | 1140 | :- pragma foreign_enum("C", status/0, [ 1141 | ready - "0", 1142 | yield - "LUA_YIELD", 1143 | runtime_error - "LUA_ERRRUN", 1144 | syntax_error - "LUA_ERRSYNTAX", 1145 | memory_error - "LUA_ERRMEM", 1146 | unhandled_error - "LUA_ERRERR" 1147 | ] ). 1148 | 1149 | 1150 | %-----------------------------------------------------------------------------% 1151 | % 1152 | % Value Passing 1153 | % 1154 | 1155 | :- pragma foreign_proc("C", lua_isnumber(Index::in, L::in), 1156 | [promise_semipure, will_not_call_mercury], 1157 | " SUCCESS_INDICATOR = lua_isnumber(L, Index);"). 1158 | 1159 | :- pragma inline(lua_isnumber/2). 1160 | 1161 | :- pragma foreign_proc("C", lua_isstring(Index::in, L::in), 1162 | [promise_semipure, will_not_call_mercury], 1163 | " SUCCESS_INDICATOR = lua_isstring(L, Index);"). 1164 | 1165 | :- pragma inline(lua_isstring/2). 1166 | 1167 | :- pragma foreign_proc("C", lua_isinteger(Index::in, L::in), 1168 | [promise_semipure, will_not_call_mercury], 1169 | " 1170 | if(lua_isnumber(L, Index)); 1171 | SUCCESS_INDICATOR = 1172 | !(lua_tonumber(L, Index) - lua_tointeger(L, Index));"). 1173 | 1174 | :- pragma inline(lua_isinteger/2). 1175 | 1176 | :- pragma foreign_proc("C", lua_isthread(Index::in, L::in), 1177 | [promise_semipure, will_not_call_mercury], 1178 | "SUCCESS_INDICATOR = lua_isthread(L, Index);"). 1179 | 1180 | :- pragma inline(lua_isthread/2). 1181 | 1182 | :- pragma foreign_proc("C", lua_isnil(Index::in, L::in), 1183 | [promise_semipure, will_not_call_mercury], 1184 | "SUCCESS_INDICATOR = lua_isnil(L, Index);"). 1185 | 1186 | :- pragma inline(lua_isnil/2). 1187 | 1188 | :- pragma foreign_proc("C", lua_isuserdata(Index::in, L::in), 1189 | [promise_semipure, will_not_call_mercury], 1190 | "SUCCESS_INDICATOR = lua_isuserdata(L, Index);"). 1191 | 1192 | :- pragma inline(lua_isuserdata/2). 1193 | 1194 | :- pragma foreign_proc("C", lua_ismruserdata(Index::in, L::in), 1195 | [promise_semipure, will_not_call_mercury], " 1196 | int Top = lua_gettop(L); 1197 | lua_pushvalue(L, Index); /* 1 */ 1198 | if(lua_isuserdata(L, -1) && lua_getmetatable(L, -1)) { /* 2 */ 1199 | lua_pushstring(L, LUA_MR_USERDATA); 1200 | lua_rawget(L, -2); 1201 | SUCCESS_INDICATOR = lua_toboolean(L, -1); 1202 | lua_settop(L, Top); 1203 | } else { 1204 | SUCCESS_INDICATOR = 0; 1205 | lua_settop(L, Top); 1206 | } 1207 | "). 1208 | 1209 | :- pragma foreign_export("C", lua_ismruserdata(in, in), 1210 | "apollo_ismruserdata"). 1211 | 1212 | :- pragma foreign_proc("C", lua_istable(Index::in, L::in), 1213 | [promise_semipure, will_not_call_mercury], 1214 | "SUCCESS_INDICATOR = lua_istable(L, Index);"). 1215 | 1216 | :- pragma inline(lua_istable/2). 1217 | 1218 | :- pragma foreign_proc("C", lua_islightuserdata(Index::in, L::in), 1219 | [promise_semipure, will_not_call_mercury], 1220 | "SUCCESS_INDICATOR = lua_islightuserdata(L, Index);"). 1221 | 1222 | :- pragma inline(lua_islightuserdata/2). 1223 | 1224 | :- pragma foreign_proc("C", lua_isboolean(Index::in, L::in), 1225 | [promise_semipure, will_not_call_mercury], 1226 | "SUCCESS_INDICATOR = lua_isboolean(L, Index);"). 1227 | 1228 | :- pragma inline(lua_isboolean/2). 1229 | 1230 | :- pragma foreign_proc("C", lua_isfunction(Index::in, L::in), 1231 | [promise_semipure, will_not_call_mercury], 1232 | "SUCCESS_INDICATOR = lua_isfunction(L, Index);"). 1233 | 1234 | :- pragma inline(lua_isfunction/2). 1235 | 1236 | :- pragma foreign_proc("C", lua_iscfunction(Index::in, L::in), 1237 | [promise_semipure, will_not_call_mercury], 1238 | "SUCCESS_INDICATOR = lua_iscfunction(L, Index);"). 1239 | 1240 | :- pragma inline(lua_iscfunction/2). 1241 | 1242 | 1243 | %-----------------------------------------------------------------------------% 1244 | 1245 | :- pragma foreign_proc("C", lua_tonumber(Index::in, L::in) = (V::out), 1246 | [promise_semipure, will_not_call_mercury], 1247 | "V = lua_tonumber(L, Index);"). 1248 | 1249 | :- pragma inline(lua_tonumber/2). 1250 | 1251 | :- pragma foreign_proc("C", lua_tostring(Index::in, L::in) = (V::out), 1252 | [promise_semipure, will_not_call_mercury], " 1253 | V = MR_copy_string(lua_tostring(L, Index)); 1254 | "). 1255 | 1256 | :- pragma foreign_proc("C", lua_tointeger(Index::in, L::in) = (V::out), 1257 | [promise_semipure, will_not_call_mercury], 1258 | "V = lua_tointeger(L, Index);"). 1259 | 1260 | :- pragma inline(lua_tointeger/2). 1261 | 1262 | :- pragma foreign_proc("C", lua_tothread(Index::in, L::in) = (V::out), 1263 | [promise_semipure, will_not_call_mercury], 1264 | "V = lua_tothread(L, Index);"). 1265 | 1266 | :- pragma inline(lua_tothread/2). 1267 | 1268 | lua_touserdata(Index, L) = U :- 1269 | semipure lua_ismruserdata(Index, L) -> 1270 | semipure U = lua_tomruserdata(Index, L) 1271 | ; 1272 | semipure C = lua_tocuserdata(Index, L), 1273 | U = univ(C). 1274 | 1275 | :- semipure func lua_tomruserdata(index, lua) = univ. 1276 | 1277 | :- pragma foreign_proc("C", lua_tomruserdata(Index::in, L::in) = (V::out), 1278 | [promise_semipure, will_not_call_mercury], 1279 | "V = **(MR_Word **)lua_touserdata(L, Index);"). 1280 | 1281 | :- pragma inline(lua_touserdata/2). 1282 | 1283 | :- pragma foreign_proc("C", lua_tocuserdata(Index::in, L::in) = (V::out), 1284 | [promise_semipure, will_not_call_mercury], 1285 | "V = (size_t)lua_touserdata(L, Index);"). 1286 | 1287 | :- pragma inline(lua_tocuserdata/2). 1288 | 1289 | :- pragma foreign_proc("C", lua_toboolean(Index::in, L::in) = (V::out), 1290 | [promise_semipure, will_not_call_mercury], 1291 | "V = lua_toboolean(L, Index) ? MR_YES : MR_NO;"). 1292 | 1293 | :- pragma inline(lua_toboolean/2). 1294 | 1295 | :- pragma foreign_proc("C", lua_tocfunction(Index::in, L::in) = (V::out), 1296 | [promise_semipure, will_not_call_mercury], 1297 | "V = lua_tocfunction(L, Index);"). 1298 | 1299 | :- pragma inline(lua_tocfunction/2). 1300 | 1301 | :- pragma foreign_proc("C", lua_toref(Index::in, L::in) = (V::out), 1302 | [promise_semipure, will_not_call_mercury], 1303 | "V = (apollo_Ref)apollo_newref(L, Index);"). 1304 | 1305 | :- pragma inline(lua_toref/2). 1306 | 1307 | 1308 | %-----------------------------------------------------------------------------% 1309 | 1310 | :- pragma foreign_proc("C", lua_pushnumber(V::in, L::in), 1311 | [will_not_call_mercury], 1312 | "lua_pushnumber(L, V);"). 1313 | 1314 | :- pragma inline(lua_pushnumber/2). 1315 | 1316 | :- pragma foreign_proc("C", lua_pushstring(V::in, L::in), 1317 | [will_not_call_mercury], 1318 | "lua_pushstring(L, V);"). 1319 | 1320 | :- pragma inline(lua_pushstring/2). 1321 | 1322 | :- pragma foreign_proc("C", lua_pushinteger(V::in, L::in), 1323 | [will_not_call_mercury], 1324 | "lua_pushinteger(L, V);"). 1325 | 1326 | :- pragma inline(lua_pushinteger/2). 1327 | 1328 | :- pragma foreign_proc("C", lua_pushthread(L::in), 1329 | [will_not_call_mercury], 1330 | "lua_pushthread(L);"). 1331 | 1332 | :- pragma inline(lua_pushthread/1). 1333 | 1334 | :- pragma foreign_proc("C", lua_pushthread(L::in) = (Main::out), 1335 | [will_not_call_mercury], " 1336 | Main = lua_pushthread(L) ? MR_YES : MR_NO;"). 1337 | 1338 | :- pragma inline(lua_pushthread/1). 1339 | 1340 | :- pragma foreign_proc("C", lua_pushnil(L::in), 1341 | [will_not_call_mercury], 1342 | "lua_pushnil(L);"). 1343 | 1344 | :- pragma inline(lua_pushnil/1). 1345 | 1346 | lua_pushuserdata(V, L) :- 1347 | impure lua_pushuniv(univ(V), L). 1348 | 1349 | :- pragma inline(lua_pushuserdata/2). 1350 | 1351 | :- pragma foreign_proc("C", lua_pushuniv(V::in, L::in), 1352 | [will_not_call_mercury], " 1353 | MR_Word * mr_ptr = apollo_new(V); 1354 | MR_Word ** lua_ptr = lua_newuserdata(L, sizeof(MR_Word **)); 1355 | *lua_ptr = mr_ptr; 1356 | apollo_set_userdata_metatable(L, -1); 1357 | "). 1358 | 1359 | 1360 | :- pragma foreign_proc("C", lua_pushlightuserdata(V::in, L::in), 1361 | [will_not_call_mercury], 1362 | "lua_pushlightuserdata(L, (void *)V);"). 1363 | 1364 | :- pragma inline(lua_pushlightuserdata/2). 1365 | 1366 | :- pragma foreign_proc("C", lua_pushboolean(V::in, L::in), 1367 | [will_not_call_mercury], 1368 | "lua_pushboolean(L, V == MR_YES ? 1 : 0);"). 1369 | 1370 | :- pragma inline(lua_pushboolean/2). 1371 | 1372 | lua_pushpred(V, L) :- 1373 | impure lua_pushuserdata(func_udata(V), L), 1374 | impure lua_pushcclosure(mr_call_ptr, 1, L). 1375 | 1376 | 1377 | :- pragma foreign_proc("C", lua_pushcfunction(V::in, L::in), 1378 | [will_not_call_mercury], 1379 | "lua_pushcfunction(L, V);"). 1380 | 1381 | :- pragma inline(lua_pushcfunction/2). 1382 | 1383 | :- pragma foreign_proc("C", lua_pushcclosure(V::in, Up::in, L::in), 1384 | [will_not_call_mercury], 1385 | "lua_pushcclosure(L, V, Up);"). 1386 | 1387 | :- pragma inline(lua_pushcclosure/3). 1388 | 1389 | :- pragma foreign_proc("C", lua_pushref(V::in, L::in), 1390 | [will_not_call_mercury], 1391 | "apollo_pushref(L, V);"). 1392 | 1393 | :- pragma inline(lua_pushref/2). 1394 | 1395 | %-----------------------------------------------------------------------------% 1396 | 1397 | :- impure pred set_userdata_metatable(index::in, lua::in) is det. 1398 | 1399 | :- pragma foreign_proc("C", set_userdata_metatable(I::in, L::in), 1400 | [will_not_call_mercury], "apollo_set_userdata_metatable(L, I);"). 1401 | 1402 | :- pragma inline(set_userdata_metatable/2). 1403 | 1404 | :- pragma foreign_decl("C", " 1405 | void apollo_set_userdata_metatable(lua_State *, int); 1406 | "). 1407 | 1408 | :- pragma foreign_code("C", " 1409 | 1410 | void apollo_set_userdata_metatable(lua_State * L, int I) { 1411 | lua_pushvalue(L, I); 1412 | 1413 | if(!lua_getmetatable(L, -1)) 1414 | lua_newtable(L); 1415 | 1416 | 1417 | 1418 | lua_pushstring(L, LUA_MR_USERDATA); 1419 | lua_pushboolean(L, 1); 1420 | lua_rawset(L, -3); 1421 | 1422 | lua_pushstring(L, ""__GC""); 1423 | lua_pushcfunction(L, (lua_CFunction)apollo_free); 1424 | lua_rawset(L, -3); 1425 | 1426 | lua_pushstring(L, ""__tostring""); 1427 | lua_pushcfunction(L, (lua_CFunction)apollo_tostring); 1428 | lua_rawset(L, -3); 1429 | 1430 | lua_setmetatable(L, -2); 1431 | 1432 | lua_pop(L, 1); 1433 | } 1434 | "). 1435 | 1436 | 1437 | %-----------------------------------------------------------------------------% 1438 | %-----------------------------------------------------------------------------% 1439 | 1440 | 1441 | 1442 | 1443 | -------------------------------------------------------------------------------- /apollo.init: -------------------------------------------------------------------------------- 1 | INIT mercury__apollo__init 2 | INIT mercury__trail__init 3 | INIT mercury__apollo__api__init 4 | INIT mercury__apollo__state__init 5 | -------------------------------------------------------------------------------- /apollo.m: -------------------------------------------------------------------------------- 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: apollo.m 10 | % Main author: C4Cypher. 11 | % Stability: low. 12 | % 13 | % This file presents an interface for handling and passing values between 14 | % compiled Mercury modules and the Lua runtime VM. 15 | % 16 | % Lua is known for being a lightweight, easy to write, (comparatively) fast 17 | % dynamically typed scripting language. With first-class functions, lexical 18 | % closures, varadic argument-passing/variable-assignment, it offers a set of 19 | % language features one might expect of a functional language, rather than an 20 | % imperative scripting language. With the usage of metatables and a stack 21 | % based C interface, Lua is extremely exstensible and easily embedded or bound 22 | % with other languages. This flexibility allows Lua programmers to define 23 | % and use their own semantics, be it functional, object-oriented or otherwise. 24 | % 25 | % 26 | % The Semantic gap. 27 | % 28 | % a Lua program can be considered a set of instructions on what to do to. 29 | % These instructions impose changes oand when.In Lua, statements represent 30 | % imperative changes to the Lua state by producing side effects. In sequential 31 | % order, Lua evaluates each statement and modifies the Lua state to reflect the 32 | % truth-value intended by the statement, within the context of the local scope. 33 | % As such, Instead of requiring the declaration and deletion of variables, Lua 34 | % uses 'nil' to represent unnasigned values. 35 | % 36 | % In Lua, 'Foo = 3' can be read as 'Foo is now the number 3'. 37 | % 38 | % In contrast to Lua's imperative semantics, Mercury is a purely declarative 39 | % language. A Mercury program can be considered a set of predicates that 40 | % describe whether or not things are true. Mercury variables aren't containers 41 | % for values that can change, they represent values that Mercury may not know. 42 | % A 'free' variable is one whose value has not yet been determined. 43 | % 44 | % in Mercury, 'Foo = 3' can be read as 'Foo is 3', a statement that can either 45 | % be true or false. 46 | % 47 | % These are two very different ways of looking at things, and in order to 48 | % bridge that gap, this Library defines a means of expressing Lua in a given 49 | % context at a specific moment in time. That context may be the entire Lua 50 | % state of execution, or it could only be the local scope inside a function 51 | % call. 52 | % 53 | %-----------------------------------------------------------------------------% 54 | %-----------------------------------------------------------------------------% 55 | 56 | :- module apollo. 57 | 58 | 59 | :- interface. 60 | 61 | :- include_module state. 62 | :- include_module api. 63 | 64 | % Note: The impure operations defined in the api and modules are used to 65 | % implement this library, however they do not fully conform to the semantics of 66 | % the prodedures in this library. Semipure procedures should be safe to be 67 | % called without special consideration. However; the impure prodedures in the 68 | % api module WILL produce side effects that will produce undefined behavior in 69 | % this library if they are not properly implemented. Use the api module at your 70 | % own risk. 71 | 72 | :- import_module io. 73 | :- import_module float. 74 | :- import_module int. 75 | :- import_module bool. 76 | :- import_module string. 77 | :- import_module list. 78 | :- import_module univ. 79 | 80 | 81 | %-----------------------------------------------------------------------------% 82 | % 83 | % The Lua State in an impure context 84 | % 85 | 86 | % A refrence to the Lua VM as defined by the lua_State type in lua.h 87 | % 88 | :- type lua. 89 | 90 | :- mode li == in(bound(lua)). 91 | :- mode lo == out(bound(lua)). 92 | 93 | 94 | 95 | %-----------------------------------------------------------------------------% 96 | % 97 | % The Lua State as a mutable state variable 98 | % 99 | 100 | % A refrence to the Lua state meant to be passed in a safe, 101 | % declarative manner. 102 | % 103 | :- type lua_state. 104 | 105 | % Abbriviations for lua_state. 106 | % 107 | :- type ls == lua_state. 108 | 109 | % Create a new Lua state. 110 | % 111 | :- pred new_state(ls::uo) is det. 112 | 113 | :- func new_state = lua_state. 114 | :- mode new_state = uo is det. 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | %-----------------------------------------------------------------------------% 123 | % 124 | % Initializing the Lua state 125 | % 126 | 127 | % Set up the Lua state so that it has all of the assigned values 128 | % Mercury needs to interact with it. 129 | % 130 | :- pred init_lua(lua::in, io::di, io::uo) is det. 131 | :- pred init_lua(lua_state::di, lua_state::uo) is det. 132 | 133 | % Check to see if lua_init has been called on a Lua state. 134 | % 135 | :- semipure pred ready(lua::in) is semidet. 136 | 137 | :- pred ready(bool, ls, ls). 138 | :- mode ready(out, di, uo) is det. 139 | :- mode ready(out, mdi, muo) is det. 140 | 141 | 142 | :- pred ready(ls::mdi, ls::muo) is semidet. 143 | 144 | %-----------------------------------------------------------------------------% 145 | % 146 | % Lua variables and values 147 | % 148 | 149 | 150 | 151 | 152 | % A Lua variable can be used to store any value that can be stored as a 153 | % C type. Furthermore, because variables are instantiated and stored within 154 | % the Lua state, Mercury cannot construct, deconstruct, equality test or 155 | % refrence Lua variables directly like it can C types. These operations are 156 | % handled by the C API. 157 | 158 | :- type var 159 | ---> local(index) % An index on the the local stack 160 | ; index(value, var) % Value stored in a table 161 | ; meta(var) % A variable's metatable 162 | 163 | % The following are meant for internal use 164 | ; ref(ref) % A strong refrence (like a pointer) 165 | ; global(string) % A global variable 166 | 167 | % Returned on invalid request. 168 | ; invalid(string). 169 | 170 | 171 | 172 | 173 | % Var ^ T = index(value(T), Var). 174 | % Syntactic sugar for accessing the elements of a table, 175 | % assuming Var is a Table. If Var is NOT a table, Lua may respond with a 176 | % runtime error when it gets passed a variable constructed in this manner. 177 | % 178 | :- func var ^ T = var. 179 | 180 | :- type vars == list(var). 181 | 182 | % A given var is valid. 183 | :- pred valid_var(var, ls, ls). 184 | :- mode valid_var(in, mdi, muo) is semidet. 185 | 186 | :- pred valid_var(var, bool, ls, ls). 187 | :- mode valid_var(in, out, di, uo) is det. 188 | :- mode valid_var(in, out, mdi, muo) is det. 189 | 190 | 191 | % Test equality on vars (no metamethods) 192 | :- pred var_equal(var::in, var::in, ls::mdi, ls::muo) is semidet. 193 | 194 | 195 | % The ref type represents a strong refrence to a Lua variable instantiated in 196 | % Lua, as a result, a refrenced variable will not be garbage collected by Lua 197 | % until said refrence is unregistered or re-assigned. 198 | % 199 | % Note that these refrences discussed here are NOT normal C pointers, but values 200 | % internal to Lua's register-based VM. 201 | 202 | :- type ref. 203 | 204 | % The index type is used to directly refrence variables on the Lua stack 205 | 206 | :- type index. 207 | 208 | %:- func ref(var) = ref. 209 | 210 | 211 | % A union of all of the types that can be natively passed to and from 212 | % Lua. 213 | % 214 | :- type value 215 | ---> nil(nil) % the abscence of value 216 | ; number(float) % double prescision, casts to float 217 | ; integer(int) % int cast to Lua number 218 | ; boolean(bool) % boolean truth values, casts to bool 219 | ; string(string) % string value, casts to string 220 | ; lightuserdata(c_pointer) % naked C pointer 221 | ; thread(lua) % A coroutine 222 | ; c_function(c_function) % A Lua callable function pointer 223 | ; var(var) % A Lua variable 224 | ; userdata(univ) % opaque type in Lua for handling foreign data 225 | ; lua_error(lua_error). % May be returned from a Lua function on error. 226 | 227 | :- type values == list(value). 228 | 229 | % values are ground data types that can be cast back and forth from mercury 230 | % types without help from the Lua runtime. The cc_nondet modes should 231 | % properly cast ints and floats via backtracking. 232 | % 233 | :- func value(T) = value. 234 | :- mode value(in) = out is det. 235 | :- mode value(out) = in is cc_nondet. 236 | 237 | :- pred value(value, T). 238 | :- mode value(out, in) is det. 239 | :- mode value(in, out) is cc_nondet. 240 | 241 | % A Lua callable function defined in C and refrenced via pointer 242 | :- type c_function. 243 | 244 | % Test equality on values (no metamethods) 245 | :- pred value_equal(value::in, value::in, ls::mdi, ls::muo) is semidet. 246 | 247 | % The nil value 248 | % 249 | % In Lua, nil represents the abscence of value. Looking up a key in a Lua table 250 | % that is not assigned a value with produce a nil result. 251 | % 252 | % Furthermore, assigning a key value to nil will unassign that value. Note that 253 | % this does not neccicarily delete the value, if Lua holds a refrence to that 254 | % value elsewhere, it will not be garbage collected. 255 | % 256 | % In normal Lua semantics, using nil as a key value produces an error, however 257 | % due to the Mercury semantics used in this library, doing so will either fail 258 | % or return another nil value. This is both for the sake of safer runtime 259 | % integration of Mercury's strict type system with Lua's dynamic type system, 260 | % and also as a practical consideration of Mercury's potentially 261 | % nondeterministic nature, as testing for a paticular type wil result in a 262 | % backtracking failure. 263 | % 264 | % It is to be noted that Lua's nil value is not to be confused with C's NULL 265 | % value. While used in similar ways, Lua will interpret C's NULL as the number 266 | % zero, wheras C has no direct representation for Lua's nil value. 267 | % 268 | % As a result of this, Lua's semantics on conditional tests are slightly 269 | % different than C's. C interprets any numeric value other than 0 as true. 270 | % In contrast, Lua interprets ANY value other than boolean false or nil as true. 271 | 272 | :- type nil ---> nil. 273 | 274 | % Retreive the value of a var in Lua without triggering metatables. 275 | % 276 | :- pred get(var, value, ls, ls). 277 | :- mode get(in, out, di, uo) is det. 278 | :- mode get(in, out, mdi, muo) is det. 279 | 280 | :- func get(var, ls, ls) = value. 281 | :- mode get(in, di, uo) = out is det. 282 | :- mode get(in, mdi, muo) = out is det. 283 | 284 | % Change the value of a var in Lua 285 | % These calls are now backtrackable due to the trailing module 286 | % 287 | :- pred set(var, value, ls, ls). 288 | :- mode set(in, in, di, uo) is det. 289 | :- mode set(in, in, mdi, muo) is det. 290 | 291 | 292 | % Change the value of a var in Lua, making sure to not trigger metatables. 293 | % 294 | 295 | % Create a new variable local to the environment initial value will be nil 296 | % if the lua state is mostly unique the variable is trailed and will be 297 | % undone on backtrack. 298 | % 299 | :- pred local(var, ls, ls). 300 | :- mode local(out, di, uo) is det. 301 | :- mode local(out, mdi, muo) is det. 302 | 303 | :- func local(ls, ls) = var. 304 | :- mode local(di, uo) = out is det. 305 | :- mode local(mdi, muo) = out is det. 306 | 307 | 308 | %-----------------------------------------------------------------------------% 309 | % 310 | % Lua tables 311 | % 312 | 313 | % Create new Lua table and pass it as a local. 314 | % 315 | :- func local_table(ls, ls) = var. 316 | :- mode local_table(di, uo) = out is det. 317 | :- mode local_table(mdi, muo) = out is det. 318 | 319 | :- pred local_table(var, ls, ls). 320 | :- mode local_table(out, di, uo) is det. 321 | :- mode local_table(out, mdi, muo) is det. 322 | 323 | 324 | % Create new Lua table and pass it to Mercury as a refrence 325 | % 326 | :- func ref_table(ls, ls) = var. 327 | :- mode ref_table(di, uo) = out is det. 328 | :- mode ref_table(mdi, muo) = out is det. 329 | 330 | :- pred ref_table(var, ls, ls). 331 | :- mode ref_table(out, di, uo) is det. 332 | :- mode ref_table(out, mdi, muo) is det. 333 | 334 | % The first key-value pair from a table, fails if var is not a table or 335 | % if the table is empty. 336 | % 337 | :- pred first(var, value, value, ls, ls). 338 | :- mode first(in, out, out, mdi, muo) is semidet. 339 | 340 | % Det version, returns nil values if table is empty or var is not a table 341 | :- pred det_first(var, value, value, ls, ls). 342 | :- mode det_first(in, out, out, di, uo) is det. 343 | :- mode det_first(in, out, out, mdi, muo) is det. 344 | 345 | % Accepts a key value and returns the next key value pair when iterating 346 | % over a table. Fails if there is no next pair. 347 | % 348 | :- pred next(var, value, value, value, ls, ls). 349 | :- mode next(in, in, out, out, mdi, muo) is semidet. 350 | 351 | % Det version of next, nil values returned if there is no next pair 352 | % 353 | :- pred det_next(var, value, value, value, ls, ls). 354 | :- mode det_next(in, in, out, out, di, uo) is det. 355 | :- mode det_next(in, in, out, out, mdi, muo) is det. 356 | 357 | 358 | %-----------------------------------------------------------------------------% 359 | % 360 | % Lua functions 361 | % 362 | 363 | 364 | 365 | % This is the type signature for mercury predicates that can be called as 366 | % Lua functions. Unless you're familiar with the calls in apollo.api, please 367 | % use the provided constructor functions to create mr_pred values. 368 | % 369 | :- type mr_func == (impure func(lua)= int). 370 | 371 | :- inst mr_func == (func(in) = out is det). 372 | 373 | :- mode mri == in(mr_func). 374 | :- mode mro == out(mr_func). 375 | 376 | 377 | % Accepts a Mercury function that takes a list of lua variables and 378 | % returns a list of lua variables. If a semidet function fails, then 379 | % the pred will return nil to lua. 380 | % 381 | :- func make_lua_func(func(vars, ls, ls) = vars) = mr_func. 382 | :- mode make_lua_func(in(func(in, di, uo) = out is det)) = mro is det. 383 | :- mode make_lua_func(in(func(in, di, uo) = out is semidet)) = mro is det. 384 | 385 | % Acceps a Mercury function that takes a list of variables and returns 386 | % one Lua variable. In Lua, the function will return nil on failure, or 387 | % if the function finds multiple solutions, they will all be returned 388 | % 389 | :- func make_nondet_lua_func(func(vars, ls, ls) = var) = mr_func. 390 | :- mode make_nondet_lua_func(in(func(in, di, uo) = out is det)) = mro is det. 391 | :- mode make_nondet_lua_func(in(func(in, di, uo) = out is semidet)) 392 | = mro is det. 393 | :- mode make_nondet_lua_func(in(func(in, di, uo) = out is multi)) = mro is det. 394 | :- mode make_nondet_lua_func(in(func(in, di, uo) = out is nondet)) 395 | = mro is det. 396 | 397 | 398 | % Accepts a string chunk of lua code and compiles it to a lua function, 399 | % passing it by refrence. If the compile fails, a refrecnce to a lua_error 400 | % userdata object will be returned instead. 401 | % 402 | :- pred string_to_func(string, var, ls, ls). 403 | :- mode string_to_func(in, out, di, uo) is det. 404 | 405 | :- func string_to_func(string, ls, ls) = var. 406 | :- mode string_to_func(in, di, uo) = out is det. 407 | 408 | % Calls a lua variable as if it were a function, this may be unsafe if the 409 | % variable is not a function or does not have a __call metamethod defined 410 | % 411 | :- pred call_lua_func(var, values, values, ls, ls). 412 | :- mode call_lua_func(in, in, out, di, uo) is det. 413 | 414 | :- func call_lua_func(var, values, ls, ls) = values. 415 | :- mode call_lua_func(in, in, di, uo) = out is det. 416 | 417 | 418 | 419 | 420 | 421 | 422 | 423 | %-----------------------------------------------------------------------------% 424 | % 425 | % Lua modules 426 | % 427 | 428 | % register_module(Module, L, !IO). 429 | % 430 | % Register a module in Lua. 431 | % 432 | %:- pred register_module(string::in, lua_func::in, lua::in, 433 | % io::di, io::uo) is det. 434 | 435 | 436 | %-----------------------------------------------------------------------------% 437 | % 438 | % Lua types 439 | % 440 | 441 | :- type lua_type 442 | ---> none % rarely used, represents invalid type 443 | ; nil_type 444 | ; number_type 445 | ; boolean_type 446 | ; string_type 447 | ; lightuserdata_type 448 | ; function_type 449 | ; table_type 450 | ; thread_type 451 | ; userdata_type. 452 | 453 | % Look up the Lua type of a given variable. 454 | % 455 | :- pred var_type(var, lua_type, ls, ls). 456 | :- mode var_type(in, out, di, uo) is det. 457 | :- mode var_type(in, out, mdi, muo) is det. 458 | 459 | :- func var_type(var, ls, ls) = lua_type. 460 | :- mode var_type(in, di, uo) = out is det. 461 | :- mode var_type(in, mdi, muo) = out is det. 462 | 463 | 464 | 465 | %-----------------------------------------------------------------------------% 466 | % 467 | % Lua errors 468 | % 469 | % Thrown when Lua experiences an error. 470 | % 471 | :- type lua_error 472 | ---> lua_error(error_type, string). 473 | 474 | :- type error_type 475 | ---> no_error 476 | ; runtime_error 477 | ; syntax_error 478 | ; memory_error 479 | ; unhandled_error. 480 | 481 | 482 | %-----------------------------------------------------------------------------% 483 | %-----------------------------------------------------------------------------% 484 | 485 | :- implementation. 486 | 487 | :- import_module apollo.api. 488 | :- import_module apollo.state. 489 | 490 | :- pragma foreign_import_module("C", apollo.api). 491 | :- pragma foreign_import_module("C", apollo.state). 492 | 493 | :- import_module char. 494 | :- import_module solutions. 495 | :- import_module exception. 496 | :- import_module type_desc. 497 | :- import_module require. 498 | 499 | 500 | :- pragma require_feature_set([conservative_gc, trailing]). 501 | 502 | :- pragma foreign_decl("C", 503 | " 504 | #include 505 | #include 506 | #include 507 | 508 | #include 509 | 510 | /* Checking for Lua language features introduced with 5.2 */ 511 | #if LUA_VERSION_NUM >= 502 512 | 513 | #define AFTER_502 514 | 515 | #else /* LUA_VERSION_NUM < 502 */ 516 | 517 | #define BEFORE_502 518 | 519 | #endif /* LUA_VERSION_NUM < 502 */ 520 | 521 | #ifdef BEFORE_502 522 | #define LUA_RIDX_MAINTHREAD 1 523 | #define LUA_RIDX_GLOBALS 2 524 | #define LUA_RIDX_LAST LUA_RIDX_GLOBALS 525 | #endif /* BEFORE_502 */ 526 | 527 | #define LUA_MR_MODULES ""LUA_MR_MODULES"" 528 | #define LUA_MR_READY ""LUA_MR_READY"" 529 | 530 | /* metatable values*/ 531 | #define LUA_MR_TYPE ""__mercury_type"" 532 | #define LUA_MR_USERDATA ""__mercury_userdata"" 533 | 534 | 535 | 536 | "). 537 | 538 | 539 | 540 | %-----------------------------------------------------------------------------% 541 | % 542 | % The Lua State 543 | % 544 | 545 | 546 | 547 | % The lua type represents the state of a running Lua Virtual Machine. (Lua VM 548 | % for short) Note that as a convention borrowed from the C API, procedures 549 | % that query or manipulate the Lua state will use the variable term 'L' to refer 550 | % to the Lua state. 551 | 552 | :- pragma foreign_type("C", lua, "lua_State *", 553 | [can_pass_as_mercury_type]). 554 | 555 | :- pragma foreign_type("C", lua_state, "apollo_lua_state *"). 556 | 557 | 558 | 559 | new_state = lua_state(lua_new, null_id, empty_trail). 560 | 561 | new_state(new_state). 562 | 563 | %-----------------------------------------------------------------------------% 564 | % 565 | % Initializing the Lua state 566 | % 567 | 568 | :- pragma foreign_proc("C", init_lua(L::in, _I::di, _O::uo), 569 | [promise_pure, will_not_call_mercury], "apollo_init(L);"). 570 | 571 | 572 | 573 | init_lua(ls(L, I, T), ls(L, I, T)) :- promise_pure( impure init_lua(L)). 574 | 575 | :- impure pred init_lua(lua::in) is det. 576 | 577 | :- pragma foreign_proc("C", init_lua(L::in), 578 | [may_call_mercury], "apollo_init(L);"). 579 | 580 | 581 | :- pragma foreign_proc("C", ready(L::in), 582 | [promise_semipure, will_not_call_mercury], " 583 | SUCCESS_INDICATOR = apollo_ready(L); 584 | "). 585 | 586 | 587 | ready(lua_state(L, I, T), lua_state(L, I, T)) :- 588 | promise_pure (semipure ready(L) ). 589 | 590 | ready(B, ls(L, I, T), ls(L, I, T)) :- 591 | promise_pure 592 | ( semipure ready(L) -> B = yes 593 | ; B = no). 594 | 595 | :- pragma foreign_decl("C", "void apollo_init(lua_State *);"). 596 | 597 | :- pragma foreign_decl("C", "int apollo_ready(lua_State *);"). 598 | 599 | :- pragma foreign_code("C", " 600 | void apollo_init(lua_State * L) 601 | { 602 | 603 | int length; 604 | 605 | #ifdef BEFORE_502 606 | 607 | /* Set the Main thread in the registry */ 608 | lua_pushvalue(L, LUA_REGISTRYINDEX); 609 | lua_pushinteger(L, LUA_RIDX_MAINTHREAD); 610 | if(!lua_pushthread(L)) 611 | MR_fatal_error(""Must init main thread.""); 612 | lua_settable(L, -3); 613 | 614 | lua_pushinteger(L, LUA_RIDX_GLOBALS); 615 | lua_pushvalue(L, LUA_GLOBALSINDEX); 616 | lua_settable(L, -3); 617 | 618 | 619 | #endif /* BEFORE_502 */ 620 | 621 | /* Add tables to the registry. */ 622 | 623 | lua_newtable(L); 624 | apollo_setregistry(L, LUA_MR_MODULES); 625 | 626 | /* Add loader to package.loaders */ 627 | lua_getglobal(L, ""package""); 628 | lua_getfield(L, -1, ""loaders""); 629 | length = apollo_len(L, 1); 630 | lua_pushinteger(L, length + 1); 631 | lua_pushcfunction(L, apollo_loader); 632 | lua_settable(L, -3); 633 | lua_pop(L, 2); 634 | 635 | /* Mark Lua as ready */ 636 | lua_pushboolean(L, 1); 637 | apollo_setregistry(L, LUA_MR_READY); 638 | } 639 | 640 | "). 641 | 642 | 643 | 644 | :- pragma foreign_code("C", " 645 | /* Check to see if Lua has already been initialized. */ 646 | int apollo_ready(lua_State * L) { 647 | int ready; 648 | 649 | lua_checkstack(L, 1); 650 | lua_pushvalue(L, LUA_REGISTRYINDEX); 651 | lua_pushstring(L, LUA_MR_READY); 652 | lua_gettable(L, -2); 653 | ready = lua_toboolean(L, 1); 654 | lua_remove(L, 1); 655 | return ready; 656 | } 657 | "). 658 | 659 | 660 | %-----------------------------------------------------------------------------% 661 | % 662 | % Variables 663 | % 664 | 665 | 666 | 667 | :- type index == int. 668 | 669 | Var ^ T = index(value(T), Var). 670 | 671 | valid_var(V, ls(L, I, T), ls(L, I, T)) :- 672 | semipure valid_var(V, L). 673 | 674 | :- pragma promise_pure(valid_var/3). 675 | 676 | valid_var(Var, Valid, ls(L, I, T), ls(L, I, T)) :- 677 | if semipure valid_var(Var, L) 678 | then Valid = yes 679 | else Valid = no. 680 | 681 | :- pragma promise_pure(valid_var/4). 682 | 683 | 684 | /* Yeah no, I'll have to revisit this later 685 | 686 | table(Table, Acc, !AccVar, ls(L, I, T), ls(L, I, T)) :- 687 | Pred = (pred(A::in, Lua::in, { B, C }::out) is nondet :- 688 | promise_pure 689 | semipure table(A, B, C, Lua) 690 | ), 691 | AccPred = (pred({A, B}::in, C::in, D::out) is det :- Acc(A, B, C, D) ), 692 | unsorted_aggregate(Pred(Table, L), AccPred, !AccVar). 693 | 694 | :- pragma promise_pure(table/6). 695 | 696 | */ 697 | 698 | 699 | 700 | var_type(V, T, ls(L, I, Tr), ls(L, I, Tr)) :- 701 | semipure var_type(V, T, L). 702 | 703 | :- pragma promise_pure(var_type/4). 704 | 705 | var_type(V, !L) = T :- var_type(V, T, !L). 706 | 707 | 708 | var_equal(V1, V2, ls(L, I, T), ls(L, I, T)) :- 709 | semipure var_equal(V1, V2, L). 710 | 711 | :- pragma promise_pure(var_equal/4). 712 | 713 | 714 | %-----------------------------------------------------------------------------% 715 | % 716 | % Refrences 717 | % 718 | 719 | 720 | 721 | :- pragma foreign_type("C", ref, "apollo_Ref", [can_pass_as_mercury_type]). 722 | 723 | :- pragma foreign_decl("C", " 724 | 725 | typedef int * apollo_Ref; 726 | 727 | apollo_Ref apollo_newref(lua_State *, int); 728 | void apollo_pushref(lua_State *, apollo_Ref); 729 | void apollo_finalizeref(lua_State *, apollo_Ref); 730 | "). 731 | 732 | :- pragma foreign_code("C", 733 | " 734 | 735 | /* Creates a new refrence from the stack */ 736 | apollo_Ref apollo_newref(lua_State * L, int index) { 737 | apollo_Ref new_ref; 738 | lua_pushvalue(L, index); 739 | new_ref = MR_GC_NEW(int); 740 | *new_ref = luaL_ref(L, LUA_REGISTRYINDEX); 741 | MR_GC_register_finalizer(new_ref, 742 | (GC_finalization_proc)apollo_finalizeref, L); 743 | return new_ref; 744 | } 745 | 746 | 747 | /* Push a refrence onto the provided stack */ 748 | void apollo_pushref(lua_State * L, apollo_Ref ref) { 749 | if (*ref == LUA_REFNIL) { 750 | lua_pushnil(L); 751 | } 752 | else { 753 | lua_rawgeti(L, LUA_REGISTRYINDEX, *ref); 754 | } 755 | } 756 | 757 | /* Remove Lua's refrence to the var in the registry */ 758 | void apollo_finalizeref(lua_State * L, apollo_Ref ref) { 759 | luaL_unref(L, LUA_REGISTRYINDEX, *ref); 760 | } 761 | 762 | "). 763 | 764 | :- impure pred finalizeref(ref::in, lua::in) is det. 765 | 766 | :- pragma foreign_proc("C", finalizeref(R::in, L::in), 767 | [will_not_call_mercury], "apollo_finalizeref(L, R);"). 768 | 769 | 770 | 771 | 772 | %-----------------------------------------------------------------------------% 773 | % 774 | % Lua values 775 | % 776 | 777 | 778 | value(T::in) = ( 779 | ( dynamic_cast(T, U:nil) -> nil(U) 780 | ; dynamic_cast(T, U:float) -> number(U) 781 | ; dynamic_cast(T, U:int) -> number(float(U)) 782 | ; dynamic_cast(T, U:int) -> integer(U) 783 | ; dynamic_cast(T, U:bool) -> boolean(U) 784 | ; dynamic_cast(T, U:string) -> string(U) 785 | ; dynamic_cast(T, U:char) -> string(string.from_char(U)) 786 | ; dynamic_cast(T, U:c_pointer) -> lightuserdata(U) 787 | ; dynamic_cast(T, U:lua) -> thread(U) 788 | ; dynamic_cast(T, U:c_function) -> c_function(U) 789 | ; dynamic_cast(T, U:var) -> var(U) 790 | ; dynamic_cast(T, U:univ) -> userdata(U) 791 | ; userdata(univ(T)) 792 | )::out). 793 | 794 | 795 | value(T::out) = (V::in) :- 796 | require_complete_switch [V] 797 | ( V = nil(N) , dynamic_cast(N, T) 798 | ; V = number(F) , dynamic_cast(F, T) 799 | ; V = integer(I) , dynamic_cast(I, T) 800 | ; V = boolean(B) , dynamic_cast(B, T) 801 | ; V = string(S) , dynamic_cast(S, T) 802 | ; V = lightuserdata(P) , dynamic_cast(P, T) 803 | ; V = thread(L) , dynamic_cast(L, T) 804 | ; V = c_function(F) , dynamic_cast(F, T) 805 | ; V = var(Var) , dynamic_cast(Var, T) 806 | ; V = userdata(U) , dynamic_cast(U, T) 807 | ; V = lua_error(E) , dynamic_cast(E, T) 808 | ; V = userdata(univ(U)) , dynamic_cast(U, T) 809 | ). 810 | 811 | 812 | 813 | 814 | :- pragma promise_pure(value/1). 815 | 816 | value(V, T) :- value(T) = V. 817 | 818 | 819 | 820 | 821 | :- pragma foreign_type("C", c_function, "lua_CFunction"). 822 | 823 | 824 | 825 | value_equal(V1, V2, ls(L, I, T), ls(L, I, T)) :- 826 | semipure value_equal(V1, V2, L). 827 | 828 | :- pragma promise_pure(value_equal/4). 829 | 830 | 831 | %-----------------------------------------------------------------------------% 832 | % 833 | % Get and Set 834 | % 835 | 836 | 837 | % Retreive the value of a var in Lua 838 | % 839 | %:- pred get(var, value, ls, ls). 840 | %:- mode get(in, out, di, uo) is det. 841 | %:- mode get(in, out, mdi, muo) is det. 842 | 843 | get(Var,Value,ls(L, I, T), ls(L, I, T)) :- 844 | impure push_var(Var, L), 845 | semipure Value = to_value(-1, L), 846 | impure lua_pop(1, L). 847 | 848 | :- pragma promise_pure(get/4). 849 | 850 | get(Var, !L) = Value :- get(Var, Value, !L). 851 | 852 | % Change the value of a var in Lua 853 | % Although these calls are considered pure due to the passing of the lua_state 854 | % Mercury can not backtrack through these or other calls that modify the 855 | % Lua state. 856 | % 857 | %:- pred set(var, value, ls, ls). 858 | %:- mode set(in, in, di, uo) is det. 859 | %:- mode set(in, in, mdi, uo) is det. 860 | 861 | set(V::in, Value::in, ls(L, Ix, T)::di, ls(L, Ix, T)::uo) :- 862 | require_complete_switch [V] ( 863 | V = local(I), 864 | impure push_value(Value, L), 865 | impure lua_replace(I, L) 866 | ; V = index(Key, Table), 867 | impure push_var(Table,L), 868 | impure push_value(Key, L), 869 | impure push_value(Value, L), 870 | impure lua_rawset(-3, L), 871 | impure lua_pop(1, L) 872 | ; V = meta(Table), 873 | impure push_var(Table, L), 874 | impure push_value(Value, L), 875 | impure lua_setmetatable(-2, L), 876 | impure lua_pop(1, L) 877 | ; V = ref(R), 878 | (dynamic_cast(R, I:int) -> 879 | impure lua_pushinteger(I, L), 880 | impure push_value(Value, L), 881 | impure lua_rawset(registryindex, L) 882 | ; 883 | throw(lua_error(runtime_error, $module ++ "." ++ $pred ++ 884 | " attempted to set invalid ref.")) 885 | ) 886 | ; V = global(S), 887 | impure lua_pushstring(S, L), 888 | impure push_value(Value, L), 889 | impure lua_rawset(globalindex, L) 890 | ; V = invalid(S), 891 | throw(lua_error(runtime_error, $module ++ "." ++ $pred ++ 892 | " attempted to set invalid var: " ++ S)) 893 | ). 894 | 895 | 896 | 897 | %:- mode set(in, in, mdi, muo) is det. 898 | 899 | set(V::in, Value::in, LS0::mdi, LS1::muo) :- 900 | 901 | LS0 = ls(L, I0, T0), 902 | 903 | 904 | require_complete_switch [V] ( 905 | V = local(I), 906 | 907 | semipure OldValue = to_value(I, L), 908 | trail_lua_closure(revert_local(I, OldValue) , ls(L, I0, T0), ls(L1, I1, T1) ), 909 | 910 | impure push_value(Value, L), 911 | impure lua_replace(I, L), 912 | 913 | LS1 = ls(L1, I1, T1) 914 | 915 | ; V = index(Key, Table), 916 | impure push_var(Table,L), 917 | impure push_value(Key, L), 918 | impure lua_rawget(-2, L), 919 | semipure OldValue = to_value(-1, L), 920 | impure lua_pop(1, L), 921 | 922 | trail_lua_closure(revert_table(Key, Table, OldValue), ls(L, I0, T0), ls(L1, I1, T1) ), 923 | 924 | impure push_value(Key, L), %? 925 | impure push_value(Value, L), 926 | impure lua_rawset(-3, L), 927 | impure lua_pop(1, L), 928 | 929 | LS1 = ls(L1, I1, T1) 930 | 931 | ; V = meta(Table), 932 | impure push_var(Table, L), 933 | 934 | ( impure lua_getmetatable(-1, L) -> true ; impure lua_pushnil(L)), 935 | semipure OldTable = to_value(-1, L), 936 | impure lua_pop(1, L), 937 | 938 | trail_lua_closure(revert_metatable(Table, OldTable) , ls(L, I0, T0), ls(L1, I1, T1) ), 939 | 940 | impure push_value(Value, L), 941 | impure lua_setmetatable(-2, L), 942 | impure lua_pop(1, L), 943 | 944 | LS1 = ls(L1, I1, T1) 945 | 946 | ; V = ref(R), 947 | ( dynamic_cast(R, I:int) -> 948 | impure lua_pushinteger(I, L), 949 | 950 | impure lua_rawget(registryindex, L), 951 | semipure OldValue = to_value(-1, L), 952 | impure lua_pop(1, L), 953 | 954 | trail_lua_closure(revert_ref(I, OldValue), ls(L, I0, T0), ls(L1, I1, T1) ), 955 | 956 | impure push_value(Value, L), 957 | impure lua_rawset(registryindex, L) 958 | ; 959 | throw(lua_error(runtime_error, $module ++ "." ++ $pred ++ 960 | " attempted to set invalid ref.")) 961 | ), 962 | LS1 = ls(L1, I1, T1) 963 | 964 | ; V = global(S), 965 | impure lua_pushstring(S, L), 966 | 967 | impure lua_rawget(globalindex, L), 968 | semipure OldValue = to_value(-1, L), 969 | impure lua_pop(1, L), 970 | 971 | trail_lua_closure(revert_global(S, OldValue), ls(L, I0, T0), ls(L1, I1, T1) ), 972 | 973 | impure push_value(Value, L), 974 | impure lua_rawset(globalindex, L), 975 | 976 | LS1 = ls(L1, I1, T1) 977 | 978 | ; V = invalid(S), 979 | throw(lua_error(runtime_error, $module ++ "." ++ $pred ++ 980 | " attempted to set invalid var: " ++ S)), 981 | I0 = I1, T0 = T1, LS1 = ls(L, I1, T1) 982 | ). 983 | 984 | :- impure func revert_local(index, value, lua) = int. 985 | 986 | revert_local(I, OldValue, L) = 0 :- 987 | impure push_value(OldValue, L), 988 | impure lua_replace(I, L). 989 | 990 | :- impure func revert_table(value, var, value, lua) = int. 991 | 992 | revert_table(Key, Table, OldValue, L) = 0 :- 993 | impure push_var(Table, L), 994 | impure push_value(Key, L), 995 | impure push_value(OldValue, L), 996 | impure lua_rawset(-3, L), 997 | impure lua_pop(1, L). 998 | 999 | 1000 | :- impure func revert_metatable(var, value, lua) = int. 1001 | 1002 | revert_metatable(Table, OldTable, L) = 0 :- 1003 | impure push_var(Table, L), 1004 | impure push_value(OldTable, L), 1005 | impure lua_setmetatable(-2, L), 1006 | impure lua_pop(1, L). 1007 | 1008 | :- impure func revert_ref(int, value, lua) = int. 1009 | 1010 | revert_ref(I, OldValue, L) = 0 :- 1011 | impure lua_pushinteger(I, L), 1012 | impure push_value(OldValue, L), 1013 | impure lua_rawset(registryindex, L). 1014 | 1015 | :- impure func revert_global(string, value, lua) = int. 1016 | 1017 | revert_global(S, OldValue, L) = 0 :- 1018 | impure lua_pushstring(S, L), 1019 | impure push_value(OldValue, L), 1020 | impure lua_rawset(globalindex, L). 1021 | 1022 | :- pragma promise_pure(set/4). 1023 | 1024 | % Create a new variable local to the environment initial value will be nil 1025 | % 1026 | %:- pred local(var, ls, ls). 1027 | %:- mode local(out, di, uo). 1028 | 1029 | local(local(I)::out, ls(L, Ix, T)::di, ls(L, Ix, T)::uo) :- 1030 | semipure Top = lua_gettop(L), 1031 | I = Top + 1, 1032 | impure lua_settop(I, L). 1033 | 1034 | local(local(I)::out, ls(L, Ix, T)::mdi, LSout::muo) :- 1035 | semipure Top = lua_gettop(L), 1036 | I = Top + 1, 1037 | impure lua_settop(I, L), 1038 | trail_lua_closure(pop_one, ls(L, Ix, T), LSout). 1039 | 1040 | :- impure func pop_one(lua) = int is det. 1041 | 1042 | pop_one(L) = 0 :- impure lua_pop(1, L). 1043 | 1044 | :- pragma promise_pure(local/3). 1045 | 1046 | %:- func local(ls, ls) = var. 1047 | %:- mode local(di, uo) = out is det. 1048 | 1049 | local(L1, L2) = V :- local(V, L1, L2). 1050 | 1051 | 1052 | %-----------------------------------------------------------------------------% 1053 | % 1054 | % Lua tables 1055 | % 1056 | 1057 | % Create new Lua table and pass it as a local. 1058 | % 1059 | %:- func local_table(ls, ls) = var. 1060 | %:= mode local_table(di, uo) = out is det. 1061 | 1062 | %:- pred local_table(var, ls, ls). 1063 | %:- pred local_table(out, di, uo) is det. 1064 | 1065 | local_table(local(I)::out, ls(L, Ix, T)::di, ls(L, Ix, T)::uo) :- 1066 | impure lua_newtable(L), 1067 | semipure I = absolute(-1, L). 1068 | 1069 | local_table(local(I)::out, ls(L, I0, T0)::mdi, L1::muo) :- 1070 | impure lua_newtable(L), 1071 | semipure I = absolute(-1, L), 1072 | trail_lua_closure(pop_one, ls(L, I0, T0), L1). 1073 | 1074 | :- pragma promise_pure(local_table/3). 1075 | 1076 | local_table(!L) = V :- local_table(V, !L). 1077 | 1078 | 1079 | % Create new Lua table and pass it to Mercury as a refrence 1080 | % 1081 | %:- func ref_table(ls, ls) = var. 1082 | %:- mode ref_table(di, uo) = out is det. 1083 | %:- mode ref_table(mdi, muo) = out is det. 1084 | 1085 | %:- pred ref_table(var, ls, ls). 1086 | %:- mode ref_table(out, di, uo) is det. 1087 | %:- mode ref_table(out, mdi, muo) is det. 1088 | 1089 | ref_table(ref(Ref)::out, ls(L, I, T)::di, ls(L, I, T)::uo):- 1090 | impure lua_newtable(L), 1091 | semipure Ref = lua_toref(-1, L), 1092 | impure lua_pop(1, L). 1093 | 1094 | ref_table(ref(Ref)::out, ls(L, I, T)::mdi, L1::muo):- 1095 | impure lua_newtable(L), 1096 | semipure Ref = lua_toref(-1, L), 1097 | trail_lua_closure((impure func(Lu) = 0 :- impure finalizeref(Ref, Lu)), ls(L, I, T), L1). 1098 | 1099 | :- pragma promise_pure(ref_table/3). 1100 | 1101 | ref_table(!L) = V :- ref_table(V, !L). 1102 | 1103 | :- pred pure_next(var::in, value::in, value::out, value::out, lua::in) 1104 | is semidet. 1105 | 1106 | pure_next(Table, Last, Next, Value, L) :- 1107 | impure push_var(Table, L), 1108 | impure push_value(Last, L), 1109 | impure lua_next(-2, L) -> 1110 | semipure Next = to_value(-2, L), 1111 | semipure Value = to_value(-1, L), 1112 | impure lua_pop(3, L) 1113 | ; impure lua_pop(1, L), fail. 1114 | 1115 | :- pragma promise_pure(pure_next/5). 1116 | 1117 | % The first key-value pair from a table, fails if the table is empty. 1118 | % 1119 | %:- pred first(var, value, value, ls, ls). 1120 | %:- mode first(in, out, out, mdi, muo) is semidet. 1121 | first(Table, Key, Value, !L) :- next(Table, nil(nil), Key, Value, !L). 1122 | 1123 | % Det version, returns nil values if table is empty 1124 | %:- pred det_first(var, value, value, ls, ls). 1125 | %:- mode det_first(in, out, out, di, uo) is det. 1126 | %:- mode det_first(in, out, out, mdi, muo) is det. 1127 | det_first(Table, Key, Value, !L) :- det_next(Table, nil(nil), Key, Value, !L). 1128 | 1129 | % Accepts a key value and returns the next key value pair when iterating 1130 | % over a table. Fails if there is no next pair. If a nil value is passed 1131 | % as the key value, the first pair is passed instead. 1132 | % 1133 | %:- pred next(var, value, value, value, ls, ls). 1134 | %:- mode next(in, in, out, out, mdi, muo) is semidet. 1135 | next(Table, Last, Next, Value, ls(L, I, T), ls(L, I, T)) :- 1136 | pure_next(Table, Last, Next, Value, L). 1137 | 1138 | 1139 | % Det version of next, nil values returned if there is no next pair 1140 | % 1141 | %:- pred det_next(var, value, value, value, ls, ls). 1142 | %:- mode det_next(in, in, out, out, di, uo) is det. 1143 | %:- mode det_next(in, in, out, out, mdi, muo) is det. 1144 | det_next(Table, Last, Next, Value, ls(L, I, T), ls(L, I, T)) :- 1145 | if pure_next(Table, Last, K, V, L) 1146 | then Next = K, Value = V 1147 | else Next = nil(nil), Value = nil(nil). 1148 | 1149 | %-----------------------------------------------------------------------------% 1150 | % 1151 | % Functions 1152 | % 1153 | 1154 | :- semipure func get_args(index, vars) = vars. 1155 | 1156 | get_args(I, Old) = New :- 1157 | I = 1 -> New = [local(1) | Old ] 1158 | ; 1159 | semipure get_args(I - 1, [local(I) | Old ]) = New. 1160 | 1161 | 1162 | :- impure pred return_args(vars::in, int::out, lua::in) is det. 1163 | 1164 | return_args(List, Count, L) :- 1165 | List = [] -> 1166 | Count = 0 1167 | ; List = [Var | Rest] -> 1168 | impure push_var(Var, L), 1169 | impure return_args(Rest, Old, L), 1170 | Count = Old + 1 1171 | ; throw(lua_error(runtime_error, $module ++ "." ++ $pred ++ 1172 | " Invalid list of vars.")). 1173 | 1174 | % Accepts a Mercury function that takes a list of lua variables and 1175 | % returns a list of lua variables. If a semidet function fails, then 1176 | % the pred will return nil to lua. 1177 | % 1178 | %:- func make_lua_func(func(vars, ls, ls) = vars) = mr_func. 1179 | %:- mode make_lua_func(in(func(in, di, uo) = out is det)) = mpo. 1180 | %:- mode make_lua_func(in(func(in, di, uo) = out is semidet)) = mpo. 1181 | %:- mode make_lua_func(in(func(in, di, uo) = out is cc_multi)) = mpo. 1182 | %:- mode make_lua_func(in(func(in, di, uo) = out is cc_nondet)) = mpo. 1183 | 1184 | 1185 | make_lua_func(Func) = (impure func(L) = Returned is det :- 1186 | semipure Top = lua_gettop(L), 1187 | semipure Args = get_args(Top, []), 1188 | LS = ls(L, current_id, empty_trail), 1189 | Return = Func(Args, LS, _) -> 1190 | impure return_args(Return, Returned, L) 1191 | ; Returned = 0 1192 | ). 1193 | 1194 | 1195 | 1196 | %:- func make_nondet_lua_func(pred(vars, ls, ls, var)) = mr_func. 1197 | %:- mode make_lua_func(in(pred(in, di, uo, out) is det)) = mpo. 1198 | %:- mode make_lua_func(in(pred(in, di, uo, out) is semidet)) = mpo. 1199 | %:- mode make_lua_func(in(pred(in, di, uo, out) is multi)) = mpo. 1200 | %:- mode make_lua_func(in(pred(in, di, uo, out) is nondet)) = mpo. 1201 | 1202 | make_nondet_lua_func(Func) = (impure func(L) = Returned is det :- 1203 | semipure Top = lua_gettop(L), 1204 | semipure Args = get_args(Top, []), 1205 | Pred = (pred(Out::out) is nondet :- 1206 | Out = Func(Args, ls(L, current_id, empty_trail), _)), 1207 | Return:vars = solutions(Pred), 1208 | impure return_args(Return, Returned, L)). 1209 | 1210 | % Accepts a string chunk of lua code and compiles it to a lua function, 1211 | % passing it by refrence. If the compile fails, a refrecnce to a lua_error 1212 | % userdata object will be returned instead. 1213 | % 1214 | %:- pred string_to_func(string, var, ls, ls) is det. 1215 | %:- mode string_to_func(in, out, di, uo) is det. 1216 | % 1217 | %:- func string_to_func(string, ls, ls) = var is det. 1218 | %:- mode string_to_func(in, di, uo) = out is det. 1219 | 1220 | string_to_func(Chunk, Var, ls(L, Ix, T), ls(L, Ix, T)) :- 1221 | impure lua_loadstring(Chunk, L) = _, 1222 | semipure I = lua_gettop(L), 1223 | semipure Ref = lua_toref(I, L), 1224 | Var = ref(Ref), 1225 | impure lua_pop(1, L). 1226 | 1227 | 1228 | :- pragma promise_pure(string_to_func/4). 1229 | 1230 | string_to_func(Chunk, L1, L2) = Var :- string_to_func(Chunk, Var, L1, L2). 1231 | 1232 | 1233 | % Calls a lua variable as if it were a function, this may be unsafe if the 1234 | % variable is not a function or does not have a __call metamethod defined 1235 | % 1236 | %:- pred call_lua_func(var, vars, vars, ls, ls) is det. 1237 | %:- mode call_lua_func(in, in, out, di, uo). 1238 | % 1239 | %:- func call_lua_func(var, vars, ls, ls) = vars is det. 1240 | %:- mode call_lua_func(in, di, uo) = out is det. 1241 | 1242 | call_lua_func(Var, Arg_List, Ret_List, ls(L, Ix, T), ls(L, Ix, T)) :- 1243 | semipure TopBefore = lua_gettop(L), 1244 | impure push_var(Var, L), % push the function onto the stack 1245 | impure push_values(Arg_List, Args, L), % push arguments onto the stack 1246 | impure lua_call(Args, multret, L), 1247 | semipure TopAfter = lua_gettop(L), 1248 | Returned = TopAfter - TopBefore, 1249 | ( Returned = 0 -> Ret_List = [] ; semipure to_values(Returned, Ret_List, L)), 1250 | impure lua_settop(TopBefore, L). 1251 | 1252 | :- pragma promise_pure(call_lua_func/5). 1253 | 1254 | call_lua_func(Var, Arg_list, !L) = Ret_List :- 1255 | call_lua_func(Var, Arg_list, Ret_List, !L). 1256 | 1257 | 1258 | 1259 | %-----------------------------------------------------------------------------% 1260 | % 1261 | % Length 1262 | % 1263 | 1264 | :- pragma foreign_decl("C", " 1265 | size_t apollo_len(lua_State *, int); 1266 | "). 1267 | 1268 | :- pragma foreign_code("C", " 1269 | 1270 | size_t apollo_len(lua_State * L, int index) { 1271 | 1272 | #ifdef BEFORE_502 1273 | return lua_objlen(L, index); 1274 | #else 1275 | return lua_rawlen(L, index); 1276 | #endif /* END BEFORE_502 */ 1277 | } 1278 | 1279 | "). 1280 | 1281 | 1282 | 1283 | 1284 | %-----------------------------------------------------------------------------% 1285 | % 1286 | % The registry, and upvalues. 1287 | % 1288 | 1289 | 1290 | :- pragma foreign_decl("C", " 1291 | void apollo_getregistry(lua_State *, const char *); 1292 | void apollo_setregistry(lua_State *, const char *); 1293 | int apollo_getupvalue(lua_State *, const int); 1294 | void apollo_setupvalue(lua_State *, const int); 1295 | "). 1296 | 1297 | 1298 | :- pragma foreign_code("C", " 1299 | void apollo_getregistry(lua_State * L, const char * k) { 1300 | lua_getfield(L, LUA_REGISTRYINDEX, k); 1301 | } 1302 | 1303 | void apollo_setregistry(lua_State * L, const char * k) { 1304 | lua_setfield(L, LUA_REGISTRYINDEX, k); 1305 | } 1306 | 1307 | int apollo_getupvalue(lua_State * L, const int id) { 1308 | lua_pushvalue(L, lua_upvalueindex(id)); 1309 | if (lua_type(L, -1) == LUA_TNONE) { 1310 | lua_pop(L, 1); 1311 | return 0; 1312 | } else { 1313 | return 1; 1314 | } 1315 | } 1316 | 1317 | void apollo_setupvalue(lua_State * L, const int id) { 1318 | lua_replace(L, lua_upvalueindex(id)); 1319 | } 1320 | 1321 | "). 1322 | 1323 | 1324 | 1325 | %-----------------------------------------------------------------------------% 1326 | % 1327 | % Lua modules 1328 | % 1329 | 1330 | /* 1331 | register_module(Name, Func, L, !IO) :- 1332 | 1333 | ( semipure ready(L) ; impure init_lua(L, !IO) ), 1334 | 1335 | ( impure lua_pushfunc(L, Func), 1336 | impure lua 1337 | ; 1338 | unexpected($module, $pred, 1339 | "function/2 did not return a ref.") 1340 | ), 1341 | impure lua_getregistry(L, LUA_RIDX_MR_MODULE), /* table -3 / 1342 | impure lua_pushstring(L, Name), /* key -2 / 1343 | impure apollo_pushref(L, R), /* value -1 / 1344 | impure lua_settable(L, -3), /* table -1 / 1345 | impure lua_pop(L, 1). /* empty stack / 1346 | 1347 | :- pragma promise_pure(register_module/5). 1348 | */ 1349 | 1350 | :- pragma foreign_decl("C", " 1351 | int apollo_loader(lua_State *); 1352 | "). 1353 | 1354 | :- pragma foreign_code("C", " 1355 | 1356 | /* take the provided module name and attempt to load an apollo module 1357 | passes any additional arguments. */ 1358 | int apollo_loader(lua_State * L) { 1359 | if (lua_isstring(L, 1)) { 1360 | const char * module_name = lua_tostring(L, 1); 1361 | apollo_getregistry(L, LUA_MR_MODULES); 1362 | lua_getfield(L, 2, module_name); 1363 | return 1; 1364 | } 1365 | return 0; 1366 | } 1367 | 1368 | "). 1369 | 1370 | 1371 | 1372 | 1373 | 1374 | 1375 | 1376 | 1377 | %-----------------------------------------------------------------------------% 1378 | % 1379 | % Lua Types 1380 | % 1381 | :- pragma foreign_enum("C", lua_type/0, 1382 | [ 1383 | none - "LUA_TNONE", 1384 | nil_type - "LUA_TNIL", 1385 | boolean_type - "LUA_TBOOLEAN", 1386 | lightuserdata_type - "LUA_TLIGHTUSERDATA", 1387 | number_type - "LUA_TNUMBER", 1388 | string_type - "LUA_TSTRING", 1389 | table_type - "LUA_TTABLE", 1390 | function_type - "LUA_TFUNCTION", 1391 | userdata_type - "LUA_TUSERDATA", 1392 | thread_type - "LUA_TTHREAD" 1393 | ]). 1394 | 1395 | %-----------------------------------------------------------------------------% 1396 | % 1397 | % Mercury userdata 1398 | % 1399 | 1400 | :- pragma foreign_decl("C", " 1401 | MR_Word * apollo_new(MR_Word); 1402 | int apollo_free(lua_State *); 1403 | "). 1404 | 1405 | :- pragma foreign_code("C", " 1406 | 1407 | MR_Word * apollo_new(MR_Word word) { 1408 | MR_Word * newptr = MR_GC_malloc_uncollectable(sizeof newptr); 1409 | *newptr = word; 1410 | return newptr; 1411 | } 1412 | 1413 | int apollo_free(lua_State * L) { 1414 | MR_Word ** ptr = lua_touserdata(L, 1); 1415 | MR_GC_free(*ptr); 1416 | return 0; 1417 | } 1418 | 1419 | "). 1420 | 1421 | :- impure func to_string(lua) = int. 1422 | 1423 | to_string(L) = 1 :- 1424 | semipure lua_touserdata(1, L) = U, 1425 | impure lua_pushstring(string.string(univ_value(U)), L). 1426 | 1427 | 1428 | 1429 | :- pragma foreign_export("C", to_string(in) = out, "apollo_tostring"). 1430 | 1431 | 1432 | 1433 | %-----------------------------------------------------------------------------% 1434 | % 1435 | % Lua errors 1436 | % 1437 | 1438 | :- pragma foreign_enum("C", error_type/0, 1439 | [ 1440 | no_error - "0", 1441 | runtime_error - "LUA_ERRRUN", 1442 | syntax_error - "LUA_ERRSYNTAX", 1443 | memory_error - "LUA_ERRMEM", 1444 | unhandled_error - "LUA_ERRERR" 1445 | ]). 1446 | 1447 | 1448 | -------------------------------------------------------------------------------- /apollo.state.m: -------------------------------------------------------------------------------- 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: apollo.state.m 10 | % Main author: c4cypher. 11 | % Stability: low. 12 | % 13 | % Utilities for making it easier to make pure calls with the lower level api. 14 | % 15 | %-----------------------------------------------------------------------------% 16 | %-----------------------------------------------------------------------------% 17 | 18 | :- module apollo.state. 19 | 20 | :- interface. 21 | 22 | :- import_module trail. 23 | 24 | % The various types that might be used to backtrack a Lua state 25 | :- type lua_trail 26 | ---> mr_func(mr_func) 27 | ; c_function(c_function) 28 | ; ref(ref) 29 | ; empty_trail. 30 | 31 | 32 | % Abbriviated choicepoint id. 33 | :- type id == choicepoint_id. 34 | 35 | % The current choicepoint. 36 | :- func current_id = id. 37 | 38 | % A null choicepoint. 39 | :- func null_id = id. 40 | 41 | % Fail if the current choicepoint is newer than 42 | % the stored choicepoint. 43 | % 44 | :- pred current(lua_state). 45 | :- mode current(mui) is semidet. 46 | 47 | :- pred current(lua_state::mdi, lua_state::muo) is semidet. 48 | 49 | 50 | 51 | % Construct or deconstruct a Lua state 52 | % 53 | :- func lua_state(lua, id, lua_trail) = lua_state. 54 | :- mode lua_state(in, in, in) = uo is det. 55 | :- mode lua_state(out, out, out) = di is det. 56 | :- mode lua_state(out, out, out) = mdi is det. 57 | 58 | % Construct or deconstruct with io state 59 | :- func lua_state(lua, id, lua_trail, io) = lua_state. 60 | :- mode lua_state(in, in, in, di) = uo is det. 61 | :- mode lua_state(out, out, out, uo) = di is det. 62 | :- mode lua_state(out, out, out, uo) = mdi is det. 63 | 64 | % Unique deconstructor 65 | % 66 | :- func unique_state(lua, id, lua_trail) = lua_state. 67 | :- mode unique_state(out, out, out) = ui is det. 68 | :- mode unique_state(out, out, out) = mui is det. 69 | 70 | % Abriviated forms 71 | :- func ls(lua, id, lua_trail) = ls. 72 | :- mode ls(in, in, in) = uo is det. 73 | :- mode ls(out, out, out) = di is det. 74 | :- mode ls(out, out, out) = mdi is det. 75 | 76 | :- func ls(lua, id, lua_trail, io) = ls. 77 | :- mode ls(in, in, in, di) = uo is det. 78 | :- mode ls(out, out, out, uo) = di is det. 79 | :- mode ls(out, out, out, uo) = mdi is det. 80 | 81 | :- func us(lua, id, lua_trail) = lua_state. 82 | :- mode us(out, out, out) = ui is det. 83 | :- mode us(out, out, out) = mui is det. 84 | 85 | % Access the members of a Lua state while preserving it's uniqueness. 86 | 87 | :- func lua(lua_state) = lua. 88 | :- mode lua(ui) = out is det. 89 | :- mode lua(mui) = out is det. 90 | 91 | :- func id(lua_state) = id. 92 | :- mode id(ui) = out is det. 93 | :- mode id(mui) = out is det. 94 | 95 | :- func trail(lua_state) = lua_trail. 96 | :- mode trail(ui) = out is det. 97 | :- mode trail(mui) = out is det. 98 | 99 | 100 | 101 | % Register a new trail function, it will be called before the existing 102 | % trail_func is called. 103 | :- pred update_lua_trail(mr_func, ls, ls). 104 | :- mode update_lua_trail(in, di, uo) is det. 105 | :- mode update_lua_trail(in, mdi, muo) is det. 106 | 107 | % Register the trail_func of a lua_state on the trail, update the 108 | % choicepoint ID, and reset the trail func. 109 | :- pred trail_lua_closure(mr_func, ls, ls). 110 | :- mode trail_lua_closure(mri, di, uo) is det. 111 | :- mode trail_lua_closure(mri, mdi, muo) is det. 112 | 113 | 114 | % If the current id is newer, trail as normally, however, if it isn't 115 | % Just update the trail_func. 116 | % 117 | :- impure pred trail_if_newer(mr_func, ls, ls). 118 | :- mode trail_if_newer(mri, di, muo) is det. 119 | :- mode trail_if_newer(mri, mdi, muo) is det. 120 | 121 | 122 | % Predicates that can be used to register a trail_func with the trail. 123 | % The latter form will only backtrack on undo, exception or retry. 124 | % 125 | :- impure pred backtrack(mr_func, lua). 126 | :- mode backtrack(mri, in) is det. 127 | 128 | :- impure func backtrack(mr_func, mr_func, lua) = int. 129 | :- mode backtrack(mri, mri, in) = out is det. 130 | 131 | :- impure pred backtrack(mr_func, mr_func, lua, int). 132 | :- mode backtrack(mri, mri, in, out) is det. 133 | 134 | :- func get_backtrack(mr_func, lua) = (impure (pred)). 135 | :- mode get_backtrack(mri, in) = out((pred) is det) is det. 136 | 137 | :- func trail_to_func(lua_trail, lua) = mr_func. 138 | :- mode trail_to_func(in, in) = mro is det. 139 | 140 | %-----------------------------------------------------------------------------% 141 | %-----------------------------------------------------------------------------% 142 | 143 | :- implementation. 144 | 145 | :- pragma foreign_decl("C", " 146 | #include 147 | #include 148 | #include 149 | "). 150 | 151 | 152 | current_id = I :- impure I = current_choicepoint_id. 153 | 154 | :- pragma promise_pure(current_id/0). 155 | 156 | null_id = null_choicepoint_id. 157 | 158 | current(L) :- choicepoint_newer(L^id, current_id). 159 | 160 | current(ls(L, I, T), ls(L, I, T)) :- choicepoint_newer(I, current_id). 161 | 162 | :- pragma foreign_decl("C", " 163 | typedef struct apollo_lua_state { 164 | lua_State * lua; 165 | MR_ChoicepointId id; 166 | MR_Word trail; 167 | } apollo_lua_state; 168 | "). 169 | 170 | %-----------------------------------------------------------------------------% 171 | 172 | :- pragma foreign_proc("C", lua_state(L::in, I::in, T::in) = (S::uo), 173 | [will_not_call_mercury, promise_pure], " 174 | 175 | apollo_lua_state * new = MR_GC_NEW(apollo_lua_state); 176 | new->lua = L; 177 | new->id = I; 178 | new->trail = T; 179 | S = new; 180 | "). 181 | 182 | 183 | :- pragma foreign_proc("C", lua_state(L::out, I::out, T::out) = (S::di), 184 | [will_not_call_mercury, promise_pure], " 185 | 186 | L = S->lua; 187 | I = S->id; 188 | T = S->trail; 189 | "). 190 | 191 | :- pragma foreign_proc("C", lua_state(L::out, I::out, T::out) = (S::mdi), 192 | [will_not_call_mercury, promise_pure], " 193 | 194 | L = S->lua; 195 | I = S->id; 196 | T = S->trail; 197 | "). 198 | 199 | :- pragma foreign_proc("C", lua_state(L::in, I::in, T::in, _IO::di) = (S::uo), 200 | [will_not_call_mercury, promise_pure], " 201 | 202 | apollo_lua_state * new = MR_GC_NEW(apollo_lua_state); 203 | new->lua = L; 204 | new->id = I; 205 | new->trail = T; 206 | S = new; 207 | "). 208 | 209 | 210 | :- pragma foreign_proc("C", lua_state(L::out, I::out, T::out, _IO::uo) = (S::di), 211 | [will_not_call_mercury, promise_pure], " 212 | 213 | L = S->lua; 214 | I = S->id; 215 | T = S->trail; 216 | "). 217 | 218 | :- pragma foreign_proc("C", lua_state(L::out, I::out, T::out, _IO::uo) = (S::mdi), 219 | [will_not_call_mercury, promise_pure], " 220 | 221 | L = S->lua; 222 | I = S->id; 223 | T = S->trail; 224 | "). 225 | 226 | %-----------------------------------------------------------------------------% 227 | 228 | :- pragma foreign_proc("C", unique_state(L::out, I::out, T::out) = (S::ui), 229 | [will_not_call_mercury, promise_pure], " 230 | 231 | L = S->lua; 232 | I = S->id; 233 | T = S->trail; 234 | "). 235 | 236 | :- pragma foreign_proc("C", unique_state(L::out, I::out, T::out) = (S::mui), 237 | [will_not_call_mercury, promise_pure], " 238 | 239 | L = S->lua; 240 | I = S->id; 241 | T = S->trail; 242 | "). 243 | 244 | %-----------------------------------------------------------------------------% 245 | 246 | :- pragma foreign_proc("C", ls(L::in, I::in, T::in) = (S::uo), 247 | [will_not_call_mercury, promise_pure], " 248 | 249 | 250 | apollo_lua_state * new = MR_GC_NEW(apollo_lua_state); 251 | new->lua = L; 252 | new->id = I; 253 | new->trail = T; 254 | S = new; 255 | "). 256 | 257 | 258 | :- pragma foreign_proc("C", ls(L::out, I::out, T::out) = (S::di), 259 | [will_not_call_mercury, promise_pure], " 260 | 261 | L = S->lua; 262 | I = S->id; 263 | T = S->trail; 264 | "). 265 | 266 | :- pragma foreign_proc("C", ls(L::out, I::out, T::out) = (S::mdi), 267 | [will_not_call_mercury, promise_pure], " 268 | 269 | L = S->lua; 270 | I = S->id; 271 | T = S->trail; 272 | "). 273 | 274 | :- pragma foreign_proc("C", ls(L::in, I::in, T::in, _IO::di) = (S::uo), 275 | [will_not_call_mercury, promise_pure], " 276 | 277 | 278 | apollo_lua_state * new = MR_GC_NEW(apollo_lua_state); 279 | new->lua = L; 280 | new->id = I; 281 | new->trail = T; 282 | S = new; 283 | "). 284 | 285 | 286 | :- pragma foreign_proc("C", ls(L::out, I::out, T::out, _IO::uo) = (S::di), 287 | [will_not_call_mercury, promise_pure], " 288 | 289 | L = S->lua; 290 | I = S->id; 291 | T = S->trail; 292 | "). 293 | 294 | :- pragma foreign_proc("C", ls(L::out, I::out, T::out, _IO::uo) = (S::mdi), 295 | [will_not_call_mercury, promise_pure], " 296 | 297 | L = S->lua; 298 | I = S->id; 299 | T = S->trail; 300 | "). 301 | 302 | %-----------------------------------------------------------------------------% 303 | 304 | :- pragma foreign_proc("C", us(L::out, I::out, T::out) = (S::ui), 305 | [will_not_call_mercury, promise_pure], " 306 | 307 | L = S->lua; 308 | I = S->id; 309 | T = S->trail; 310 | "). 311 | 312 | :- pragma foreign_proc("C", us(L::out, I::out, T::out) = (S::mui), 313 | [will_not_call_mercury, promise_pure], " 314 | 315 | L = S->lua; 316 | I = S->id; 317 | T = S->trail; 318 | "). 319 | 320 | %-----------------------------------------------------------------------------% 321 | 322 | :- pragma foreign_proc("C", lua(S::ui) = (L::out), 323 | [will_not_call_mercury, promise_pure], " 324 | 325 | L = S->lua; 326 | "). 327 | 328 | :- pragma foreign_proc("C", lua(S::mui) = (L::out), 329 | [will_not_call_mercury, promise_pure], " 330 | 331 | L = S->lua; 332 | "). 333 | 334 | :- pragma foreign_proc("C", id(S::ui) = (I::out), 335 | [will_not_call_mercury, promise_pure], " 336 | 337 | I = S->id; 338 | "). 339 | 340 | :- pragma foreign_proc("C", id(S::mui) = (I::out), 341 | [will_not_call_mercury, promise_pure], " 342 | 343 | I = S->id; 344 | "). 345 | 346 | 347 | :- pragma foreign_proc("C", trail(S::ui) = (T::out), 348 | [will_not_call_mercury, promise_pure], " 349 | 350 | T = S->trail; 351 | "). 352 | 353 | :- pragma foreign_proc("C", trail(S::mui) = (T::out), 354 | [will_not_call_mercury, promise_pure], " 355 | 356 | T = S->trail; 357 | "). 358 | 359 | 360 | %-----------------------------------------------------------------------------% 361 | 362 | update_lua_trail(F0, ls(L, I, T0), LS) :- 363 | F1 = trail_to_func(T0, L), 364 | F = backtrack(F0, F1), 365 | T = mr_func(F), 366 | LS = ls(L, I, T). 367 | 368 | 369 | trail_to_func(T, L) = F :- 370 | some [R] require_complete_switch [T] 371 | ( T = mr_func(F0) , F = 372 | ( impure func(L1) = Ret is det :- impure impure_apply(F0, L1) = Ret) 373 | ; T = empty_trail , 374 | F = ( impure func(_) = 0 is det :- true ) 375 | ; T = c_function(C) , 376 | impure lua_pushcfunction(C, L), 377 | semipure R = lua_toref(index(-1), L), 378 | F = ref_to_func(R), 379 | impure lua_pop(1, L) 380 | ; T = ref(R) , 381 | F = ref_to_func(R) 382 | ). 383 | 384 | 385 | :- pragma promise_pure(trail_to_func/2). 386 | 387 | 388 | :- func ref_to_func(ref) = mr_func. 389 | 390 | ref_to_func(R) = ( impure func(L) = Ret is det :- 391 | impure lua_pushref(R, L), 392 | semipure Err_index = lua_gettop(L), 393 | impure RV = lua_pcall(index(-1), L), 394 | ( returned(Ret0) = RV -> 395 | Ret = Ret0 - 1, 396 | impure lua_remove(index(Err_index), L) 397 | ; RV = returned_error(Err) -> 398 | impure lua_error(Err, L) 399 | ; unexpected($module, $pred, "Invalid return value. (WTF?)") 400 | ) 401 | ). 402 | 403 | %-----------------------------------------------------------------------------% 404 | 405 | trail_lua_closure(F0, LS, lua_state(L, current_id, empty_trail)) :- 406 | update_lua_trail(F0, LS, lua_state(L, _, T)), 407 | ( T = mr_func(F), P = get_backtrack(F, L) -> 408 | impure trail_closure_on_backtrack(P) 409 | ; unexpected($module, $pred, 410 | "Previous call to update_lua_trail did not convert trail to a func.") 411 | ). 412 | 413 | :- pragma promise_pure(trail_lua_closure/3). 414 | 415 | %-----------------------------------------------------------------------------% 416 | 417 | trail_if_newer(F, !L) :- 418 | current(!L) -> 419 | update_lua_trail(F, !L) 420 | ; 421 | impure trail_lua_closure(F, !L). 422 | 423 | %-----------------------------------------------------------------------------% 424 | 425 | backtrack(F, L) :- impure impure_apply(F, L) = _. 426 | 427 | backtrack(F0, F1, L) = 0 :- 428 | impure backtrack(F0, L), 429 | impure backtrack(F1, L). 430 | 431 | backtrack(F0, F1, L, 0) :- 432 | impure backtrack(F0, L), 433 | impure backtrack(F1, L). 434 | 435 | get_backtrack(F, L) = (impure (pred) is det :- impure backtrack(F, L)). 436 | 437 | 438 | -------------------------------------------------------------------------------- /template.m: -------------------------------------------------------------------------------- 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: filename.m. 10 | % Main author: c4cypher. 11 | % Stability: low. 12 | % 13 | % Describe the module. 14 | % 15 | %-----------------------------------------------------------------------------% 16 | %-----------------------------------------------------------------------------% 17 | 18 | :- module template. 19 | 20 | :- interface. 21 | 22 | 23 | -------------------------------------------------------------------------------- /test.m: -------------------------------------------------------------------------------- 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: test.m. 10 | % Main author: c4cypher. 11 | % Stability: low. 12 | % 13 | % Test the apollo library. 14 | % 15 | %-----------------------------------------------------------------------------% 16 | %-----------------------------------------------------------------------------% 17 | 18 | :- module test. 19 | 20 | :- interface. 21 | 22 | :- import_module io. 23 | 24 | :- pred main(io::di, io::uo) is cc_multi. 25 | 26 | 27 | :- implementation. 28 | 29 | :- import_module float. 30 | :- import_module int. 31 | :- import_module string. 32 | :- import_module univ. 33 | :- import_module list. 34 | :- import_module pair. 35 | :- import_module assoc_list. 36 | :- import_module exception. 37 | :- import_module require. 38 | :- import_module solutions. 39 | 40 | :- import_module trail. 41 | :- import_module apollo. 42 | :- import_module apollo.api. 43 | :- import_module apollo.state. 44 | 45 | :- pragma foreign_import_module("C", apollo). 46 | 47 | main(!IO) :- 48 | new_state(L0), 49 | HelloLua = string_to_func("print ""Hello World!""", L0, L1), 50 | call_lua_func(HelloLua, [], _, L1, _). 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | -------------------------------------------------------------------------------- /trail.m: -------------------------------------------------------------------------------- 1 | %---------------------------------------------------------------------------% 2 | % vim: ft=mercury ts=4 sw=4 et 3 | %---------------------------------------------------------------------------% 4 | % Copyright (C) 2007 The University of Melbourne. 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 | % Author: Mark Brown. 10 | % 11 | % Mercury interface to the function trailing facilities. 12 | % 13 | % See the Trailing section of the Mercury Language Reference Manual for 14 | % further information. 15 | % 16 | %---------------------------------------------------------------------------% 17 | %---------------------------------------------------------------------------% 18 | 19 | :- module trail. 20 | :- interface. 21 | 22 | :- import_module io. 23 | 24 | %---------------------------------------------------------------------------% 25 | 26 | % The various reasons why a trail function may be called. 27 | % 28 | :- type untrail_reason 29 | ---> untrail_undo 30 | ; untrail_exception 31 | ; untrail_retry 32 | ; untrail_commit 33 | ; untrail_solve 34 | ; untrail_gc. 35 | 36 | % Textual name of the untrail reason. 37 | % 38 | :- pred reason_name(untrail_reason, string). 39 | :- mode reason_name(in, out) is det. 40 | :- mode reason_name(out, in) is semidet. 41 | 42 | %---------------------------------------------------------------------------% 43 | 44 | % Call the supplied closure when untrailing past this point. 45 | % 46 | :- impure pred trail_closure(impure pred(untrail_reason)::in(pred(in) is det)) 47 | is det. 48 | 49 | % As above, but using the I/O state rather than being impure. 50 | % 51 | :- pred trail_closure_io( 52 | pred(untrail_reason, io, io)::in(pred(in, di, uo) is det), 53 | io::di, io::uo) is det. 54 | 55 | % Call the supplied closure on backtracking (that is, when the 56 | % untrail_reason is undo, exception or retry). 57 | % 58 | :- impure pred trail_closure_on_backtrack(impure (pred)::in((pred) is det)) 59 | is det. 60 | 61 | % As above, but using the I/O state rather than being impure. 62 | % 63 | :- pred trail_closure_on_backtrack_io(pred(io, io)::in(pred(di, uo) is det), 64 | io::di, io::uo) is det. 65 | 66 | %---------------------------------------------------------------------------% 67 | 68 | % Abstract type used to hold the identity of a choicepoint. 69 | % 70 | :- type choicepoint_id. 71 | 72 | % Get the current choicepoint. 73 | % 74 | :- impure func current_choicepoint_id = choicepoint_id. 75 | 76 | % Get the "null" choicepoint id. 77 | % 78 | :- func null_choicepoint_id = choicepoint_id. 79 | 80 | % Compare choicepoints for which is newer. 81 | % See the reference manual for details. 82 | % 83 | :- pred choicepoint_newer(choicepoint_id::in, choicepoint_id::in) is semidet. 84 | 85 | % Cast to an integer. 86 | % 87 | :- func choicepoint_id_to_int(choicepoint_id) = int. 88 | 89 | %---------------------------------------------------------------------------% 90 | 91 | % Output a debugging message when untrailing past this point. 92 | % 93 | :- impure pred debug_trail(io.output_stream::in) is det. 94 | 95 | %---------------------------------------------------------------------------% 96 | %---------------------------------------------------------------------------% 97 | 98 | :- implementation. 99 | 100 | :- pragma require_feature_set([trailing]). 101 | 102 | :- import_module exception. 103 | :- import_module list. 104 | :- import_module string. 105 | 106 | %---------------------------------------------------------------------------% 107 | 108 | :- pragma foreign_enum("C", untrail_reason/0, [ 109 | untrail_undo - "MR_undo", 110 | untrail_exception - "MR_exception", 111 | untrail_retry - "MR_retry", 112 | untrail_commit - "MR_commit", 113 | untrail_solve - "MR_solve", 114 | untrail_gc - "MR_gc" 115 | ]). 116 | 117 | reason_name(untrail_undo, "undo"). 118 | reason_name(untrail_exception, "exception"). 119 | reason_name(untrail_retry, "retry"). 120 | reason_name(untrail_commit, "commit"). 121 | reason_name(untrail_solve, "solve"). 122 | reason_name(untrail_gc, "gc"). 123 | 124 | %---------------------------------------------------------------------------% 125 | 126 | :- pragma foreign_proc("C", 127 | trail_closure(Pred::in(pred(in) is det)), 128 | [will_not_call_mercury], 129 | " 130 | MR_trail_function(ML_call_trail_closure_save_regs, (void *) Pred); 131 | "). 132 | 133 | :- pragma foreign_proc("C", 134 | trail_closure_io(Pred::in(pred(in, di, uo) is det), _IO0::di, _IO::uo), 135 | [promise_pure, will_not_call_mercury], 136 | " 137 | MR_trail_function(ML_call_trail_closure_save_regs, (void *) Pred); 138 | "). 139 | 140 | :- pragma foreign_proc("C", 141 | trail_closure_on_backtrack(Pred::in((pred) is det)), 142 | [will_not_call_mercury], 143 | " 144 | MR_trail_function(ML_call_trail_closure_on_backtrack, (void *) Pred); 145 | "). 146 | 147 | :- pragma foreign_proc("C", 148 | trail_closure_on_backtrack_io(Pred::in(pred(di, uo) is det), 149 | _IO0::di, _IO::uo), 150 | [promise_pure, will_not_call_mercury], 151 | " 152 | MR_trail_function(ML_call_trail_closure_on_backtrack, (void *) Pred); 153 | "). 154 | 155 | :- pragma foreign_decl("C", " 156 | #define MR_copy_fake_regs(src, dest) \\ 157 | do { \\ 158 | MR_memcpy(dest, src, sizeof(MR_Word) * MR_MAX_FAKE_REG); \\ 159 | } while(0) 160 | 161 | extern void 162 | ML_call_trail_closure_save_regs(void *pred, MR_untrail_reason reason); 163 | 164 | extern void 165 | ML_call_trail_closure_on_backtrack(void *pred, MR_untrail_reason reason); 166 | "). 167 | 168 | :- pragma foreign_code("C", " 169 | void ML_call_trail_closure_save_regs(void *pred, MR_untrail_reason reason) 170 | { 171 | MR_Word saved_regs[MR_MAX_FAKE_REG]; 172 | 173 | /* 174 | ** The current implementation of trailing does not preserve live 175 | ** (real or fake) registers across calls to MR_reset_ticket. Since 176 | ** the called Mercury code is likely to modify these, we better make 177 | ** a copy here and restore them afterwards. 178 | */ 179 | MR_save_registers(); 180 | MR_copy_fake_regs(MR_fake_reg, saved_regs); 181 | ML_call_trail_closure((MR_Word) pred, reason); 182 | MR_copy_fake_regs(saved_regs, MR_fake_reg); 183 | MR_restore_registers(); 184 | } 185 | 186 | void ML_call_trail_closure_on_backtrack(void *pred, 187 | MR_untrail_reason reason) 188 | { 189 | MR_Word saved_regs[MR_MAX_FAKE_REG]; 190 | 191 | switch(reason) { 192 | case MR_undo: /* Fall through. */ 193 | case MR_exception: /* Fall through. */ 194 | case MR_retry: 195 | /* 196 | ** See comment in ML_call_trail_closure_save_regs, above. 197 | */ 198 | MR_save_registers(); 199 | MR_copy_fake_regs(MR_fake_reg, saved_regs); 200 | ML_call_pred((MR_Word) pred); 201 | MR_copy_fake_regs(saved_regs, MR_fake_reg); 202 | MR_restore_registers(); 203 | break; 204 | 205 | case MR_solve: /* Fall through */ 206 | case MR_commit: 207 | break; 208 | 209 | default: 210 | MR_fatal_error(""trail.m: unknown MR_untrail_reason""); 211 | } 212 | } 213 | "). 214 | 215 | :- pragma foreign_export("C", 216 | call_pred(in(pred(di, uo) is det), di, uo), 217 | "ML_call_pred"). 218 | 219 | :- pred call_pred(pred(io, io)::in(pred(di, uo) is det), io::di, io::uo) 220 | is det. 221 | 222 | call_pred(Pred, !IO) :- 223 | Pred(!IO). 224 | 225 | :- pragma foreign_export("C", 226 | call_trail_closure(in(pred(in, di, uo) is det), in, di, uo), 227 | "ML_call_trail_closure"). 228 | 229 | :- pred call_trail_closure( 230 | pred(untrail_reason, io, io)::in(pred(in, di, uo) is det), 231 | untrail_reason::in, io::di, io::uo) is det. 232 | 233 | call_trail_closure(Pred, Reason, !IO) :- 234 | Pred(Reason, !IO). 235 | 236 | %---------------------------------------------------------------------------% 237 | 238 | % NOTE: it is safe to pass this as a Mercury type, since 239 | % `sizeof(MR_ChoicepointId) == sizeof(MR_Word)'. 240 | % 241 | :- pragma foreign_type("C", choicepoint_id, "MR_ChoicepointId", 242 | [can_pass_as_mercury_type]). 243 | 244 | :- pragma foreign_proc("C", 245 | current_choicepoint_id = (Id::out), 246 | [will_not_call_mercury], 247 | " 248 | Id = MR_current_choicepoint_id(); 249 | "). 250 | 251 | :- pragma foreign_proc("C", 252 | null_choicepoint_id = (Id::out), 253 | [promise_pure, thread_safe, will_not_call_mercury], 254 | " 255 | Id = MR_null_choicepoint_id(); 256 | "). 257 | 258 | :- pragma foreign_proc("C", 259 | choicepoint_newer(A::in, B::in), 260 | [promise_pure, thread_safe, will_not_call_mercury], 261 | " 262 | SUCCESS_INDICATOR = MR_choicepoint_newer(A, B); 263 | "). 264 | 265 | :- pragma foreign_proc("C", 266 | choicepoint_id_to_int(CP::in) = (N::out), 267 | [promise_pure, thread_safe, will_not_call_mercury], 268 | " 269 | N = (MR_Integer) CP; 270 | "). 271 | 272 | %---------------------------------------------------------------------------% 273 | 274 | debug_trail(S) :- 275 | impure CP = current_choicepoint_id, 276 | trace [io(!IO)] ( 277 | debug_trail_print(S, "setup", CP, !IO) 278 | ), 279 | impure trail_closure(debug_trail_pred(S, CP)). 280 | 281 | :- impure pred debug_trail_pred(io.output_stream::in, choicepoint_id::in, 282 | untrail_reason::in) is det. 283 | 284 | debug_trail_pred(S, CP, Reason) :- 285 | impure impure_true, 286 | reason_name(Reason, Name), 287 | trace [io(!IO)] ( 288 | debug_trail_print(S, Name, CP, !IO) 289 | ). 290 | 291 | :- pred debug_trail_print(io.output_stream::in, string::in, choicepoint_id::in, 292 | io::di, io::uo) is det. 293 | 294 | debug_trail_print(S, Name, CP, !IO) :- 295 | N = choicepoint_id_to_int(CP), 296 | io.format(S, "TRAIL: %-10s %d\n", [s(Name), i(N)], !IO). 297 | 298 | %---------------------------------------------------------------------------% 299 | :- end_module trail. 300 | %---------------------------------------------------------------------------% 301 | -------------------------------------------------------------------------------- /util.m: -------------------------------------------------------------------------------- 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: util.m. 10 | % Main author: c4cypher. 11 | % Stability: low. 12 | % 13 | % Utility predicates for working with Lua. 14 | % 15 | %-----------------------------------------------------------------------------% 16 | %-----------------------------------------------------------------------------% 17 | 18 | :- module template. 19 | 20 | :- interface. 21 | 22 | :- import_module float. 23 | :- import_module int. 24 | :- import_module string. 25 | :- import_module char. 26 | 27 | 28 | % Dynamically cast string and numeric values to their equivalents. 29 | 30 | :- func cast_to_string(T) = string is semidet. 31 | :- func cast_to_float(T) = float is semidet. 32 | :- func cast_to_int(T) = int is semidet. 33 | :- func cast_to_char(T) = char is semidet. 34 | 35 | :- implementation. 36 | 37 | cast_to_string(T) = 38 | string.string(T). 39 | 40 | cast_to_float(T) = 41 | ( dynamic_cast(T, F:float) -> F 42 | ; dynamic_cast(T, I:int), -> float(I) 43 | ; to_float(cast_to_string(T), F) -> F 44 | ; fail 45 | ). 46 | 47 | cast_to_int(T) = 48 | ( dynamic_cast(T, I:int) -> I 49 | ; dynamic_cast(T, F@float(truncate_to_int(F)@I)) -> I 50 | ; to_int(cast_to_string(T), I) -> I 51 | ; fail 52 | ). 53 | 54 | cast_to_char(T) = C :- 55 | cast_to_string(T), 56 | length(S) = 1, 57 | det_index(S, 1, C). 58 | 59 | --------------------------------------------------------------------------------