Tue Jul 13 21:17:41 CEST 2010 Tobias Rautenkranz * Use libsmokebase instead of libsmokeqtcore. Sat Apr 3 21:11:26 CEST 2010 Tobias Rautenkranz * slot-value access for static attributes using the class instead of an object. Sat Apr 3 14:04:39 CEST 2010 Tobias Rautenkranz * Make the slot-* functions work for C++ class attributes. Allow slot-value to be used to access C++ member variables of objects. Sat Apr 3 14:03:07 CEST 2010 Tobias Rautenkranz * Fix attribute vs method map to same Lisp name clash. e.g.: setWidget() and set_widget are in Lisp both #'set-widget. Prefer the method over the attribute; the attribute will be accessible with SLOT-VALUE. Wed Mar 10 17:38:58 CET 2010 Tobias Rautenkranz * Improve missing to-lisp-translator error message. Sat Feb 20 21:56:27 CET 2010 Tobias Rautenkranz * Allow passing integers as enum arguments. Sat Feb 20 19:01:21 CET 2010 Tobias Rautenkranz * Fix overload resolution exact match for long and ulong. Sat Feb 20 18:56:48 CET 2010 Tobias Rautenkranz * Faster no overload resolution method lookup. Sat Feb 20 18:24:36 CET 2010 Tobias Rautenkranz * Cache overload resolution on sbcl Fri Feb 19 22:22:50 CET 2010 Tobias Rautenkranz * cleanup #'delete-object & optimize #'constructor-name. Fri Feb 19 22:10:24 CET 2010 Tobias Rautenkranz * No need to construct a SmokeBinding per Smoke module. Thu Feb 18 20:57:00 CET 2010 Tobias Rautenkranz * Don't dispatch virtual methods for builtin classes (reduces overhead). Thu Feb 18 19:31:47 CET 2010 Tobias Rautenkranz * Fix casting across Smoke modules. Wed Feb 17 18:05:35 CET 2010 Tobias Rautenkranz * Remove underlinking of libclsmoke and add a darwin case to the library definitons. Thanks to Elliott Slaughter Tue Feb 16 22:56:19 CET 2010 Tobias Rautenkranz * Load libsmokeqtcore instead of qt in the default case of cffi:define-foreign-library. Tue Feb 16 22:52:02 CET 2010 Tobias Rautenkranz * Fix derived-p for classes that are external in every module. Mon Feb 15 16:31:33 CET 2010 Tobias Rautenkranz * Build a shared library not a module. Fixes on build error on OS X as reported by Elliott Slaughter. Mon Feb 8 18:14:54 CET 2010 Tobias Rautenkranz * sbcl-bundle requires posix & unix Thu Feb 4 16:11:29 CET 2010 Tobias Rautenkranz * Test building libclsmoke. Wed Feb 3 17:20:56 CET 2010 Tobias Rautenkranz * Fix compiling libclsmoke with asserts enabled. smoke_get_class was not declared in this scope Reported by: Elliott Slaughter Wed Feb 3 07:44:09 CET 2010 Tobias Rautenkranz * Add missing :sb-posix dependency. Sat Jan 30 15:40:08 CET 2010 Tobias Rautenkranz * Do not warn on missing parent class. Tue Jan 26 17:26:09 CET 2010 Tobias Rautenkranz * Fix for r1077826. Not instantiable parent classes are external. (QAbstractPrintDialog) Mon Jan 25 19:47:00 CET 2010 Tobias Rautenkranz * Check enum type on overload resolution Mon Jan 25 19:46:41 CET 2010 Tobias Rautenkranz * single-float conversion Mon Jan 25 19:41:22 CET 2010 Tobias Rautenkranz * Add :arg3 for make-instance SMOKE-CLASS. Sat Jan 23 20:45:41 CET 2010 Tobias Rautenkranz * class & type size (and some more exports) Sun Jan 17 22:04:08 CET 2010 Tobias Rautenkranz * Fix class-map image loading and use the new static smoke methods. indClass() and isDerivedFrom() are now static (r1076132 and also in KDE 4.4). Sun Jan 10 18:31:42 CET 2010 Tobias Rautenkranz * Fix overload resolution when a lisp smoke module is not loaded. Sun Jan 10 18:30:48 CET 2010 Tobias Rautenkranz * Auto-recompile when the smoke module has changed. Sun Jan 10 09:49:36 CET 2010 Tobias Rautenkranz * Support modular smoke & cleanup. Sun Dec 13 13:43:58 CET 2009 Tobias Rautenkranz * Support ASDF instead of Mudballs. Sun Dec 13 11:17:08 CET 2009 Tobias Rautenkranz * Update to the new Smoke ABI (v.3) Fri Nov 6 20:27:56 CET 2009 Tobias Rautenkranz * Explicitly use old ABI (pre r1045709) Wed Sep 9 21:25:37 CEST 2009 Tobias Rautenkranz * Template types are no longer t_class. Wed Sep 9 15:22:32 CEST 2009 Tobias Rautenkranz * Smoke::t_class is now also used for classes not wrapped by Smoke & remove global-space part from enum symbols. Wed Sep 2 13:49:34 CEST 2009 Tobias Rautenkranz * Various fixes: * Allow user conversions for return values * fix destruction of objects with multiple C++ superclasses * Fix list to QList conversion dispatch Tue Sep 1 13:44:21 CEST 2009 Tobias Rautenkranz * Fix overload resolution using types and test caching the overload resolution. Sun Aug 30 16:12:44 CEST 2009 Tobias Rautenkranz * Allow deriving from multiple C++ classes. Sun Aug 30 15:51:40 CEST 2009 Tobias Rautenkranz * Make integer constants return an integer instead of an enum (e,g.: qt:graphics-item.+user-type+). Thu Aug 27 13:43:13 CEST 2009 Tobias Rautenkranz * Support the new smokegenerator (r1015073). * support const correctness * remove workarounds for the old smoke The old smoke is no longer supported. Thanks to Arno Rehn for making the smokegenerator work with cl-smoke. Sun Aug 2 12:12:41 CEST 2009 Tobias Rautenkranz * Cleanup C++ to Lisp translation Fri Jul 24 15:32:23 CEST 2009 Tobias Rautenkranz * Fix conversion sequence from QByteArray to const char*. Thu Jul 23 00:26:05 CEST 2009 Tobias Rautenkranz * Use strcmp, fix constructor & destrucor calling for classes witn namespace (phonon::MediaPlayer) and add :arg0 to :arg2 initargs Wed Jul 8 22:41:19 CEST 2009 Tobias Rautenkranz * Speedup overload resolution and some other stuff for faster C++ method calling. Wed Jul 8 16:56:52 CEST 2009 Tobias Rautenkranz * SBCL: compile time overload resolution Fri Jul 3 11:50:05 CEST 2009 Tobias Rautenkranz * Fix methods and method-maps bounds. Thu Jul 2 23:51:50 CEST 2009 Tobias Rautenkranz * Promption real to double-float Thu Jul 2 23:51:14 CEST 2009 Tobias Rautenkranz * Fix infinite loop when showing candidate functions. Thu Jul 2 21:08:40 CEST 2009 Tobias Rautenkranz * Fix undefine init_smoke* C function & cleanup finalizers when a image is saved. Wed Jul 1 12:54:01 CEST 2009 Tobias Rautenkranz * Spellcheck Wed Jul 1 00:47:39 CEST 2009 Tobias Rautenkranz * Fix for Clozure CL Tue Jun 30 22:54:49 CEST 2009 Tobias Rautenkranz * CLISP workaround finalizer for objects in weak hash table crash. Mon Jun 22 14:18:08 CEST 2009 Tobias Rautenkranz * Speedup overload resolution by calling less into C, more efficient finding of the viable methods and various optimizations. This breaks Clozure CL -- fix it later. Fri Jun 12 14:21:44 CEST 2009 Tobias Rautenkranz * Load Smoke libraries at compile time. Thu Jun 11 20:45:05 CEST 2009 Tobias Rautenkranz * futile CLISP fixes Thu Jun 11 16:35:40 CEST 2009 Tobias Rautenkranz * Modules can specify the package to place the classes, static methods and constants in. Wed Jun 10 14:01:10 CEST 2009 Tobias Rautenkranz * No need for a synchronized hash table when threads are not supported. Wed Jun 10 13:55:55 CEST 2009 Tobias Rautenkranz * Fix ownership transfer for non cxx:class objects. Mon Jun 8 11:20:54 CEST 2009 Tobias Rautenkranz * Make unreadable cycles garbage collectable. Wed Jun 3 23:55:26 CEST 2009 Tobias Rautenkranz * Added restarts to method dispatch callback. Mon Jun 1 00:22:05 CEST 2009 Tobias Rautenkranz * fix define-takes-ownership return value Sun May 31 19:41:26 CEST 2009 Tobias Rautenkranz * Ownership for return values on the stack Sat May 30 14:12:25 CEST 2009 Tobias Rautenkranz * soversion for wrappers Thu May 28 15:43:36 CEST 2009 Tobias Rautenkranz * Fix CCL and allow ASDF Wed May 27 19:47:28 CEST 2009 Tobias Rautenkranz * Condition NO-APPLICABLE-CXX-METHOD Wed May 27 19:22:08 CEST 2009 Tobias Rautenkranz * Fix error when printing a SMOKE-OBJECT with an unbound pointer slot. Wed May 27 14:20:30 CEST 2009 Tobias Rautenkranz * Fix some warnings Tue May 26 11:54:47 CEST 2009 Tobias Rautenkranz * Cleanup Lisp -> C++ conversion Mon May 25 20:39:33 CEST 2009 Tobias Rautenkranz * speed up get-struct-slot-value & cleanup Sun May 24 23:28:44 CEST 2009 Tobias Rautenkranz * Allow passing a raw pointer for an argument of type class Sun May 24 13:30:05 CEST 2009 Tobias Rautenkranz * cleanup finalization stuff Fri May 22 16:57:59 CEST 2009 Tobias Rautenkranz * Use synchronized object-map Tue May 19 15:59:22 CEST 2009 Tobias Rautenkranz * Clozure CL save image Tue May 19 13:09:12 CEST 2009 Tobias Rautenkranz * Fix loading with Clozure CL Thu May 14 14:07:00 CEST 2009 Tobias Rautenkranz * Dump Lisp image & make bundle with C wrapper libraries. Tue May 12 15:54:46 CEST 2009 Tobias Rautenkranz * Support Clozure CL Mon May 11 22:18:23 CEST 2009 Tobias Rautenkranz * Make &rest lambda list for static methods only when necessary. Mon May 11 19:55:42 CEST 2009 Tobias Rautenkranz * Support (setf (getter-method) value) for C++ set* methods. Mon May 11 16:11:35 CEST 2009 Tobias Rautenkranz * Export Lisp -> C++ API. Mon May 11 15:35:40 CEST 2009 Tobias Rautenkranz * Fix enum to int promotion. Mon May 11 14:30:33 CEST 2009 Tobias Rautenkranz * cleanup: use package alexandria. Mon May 11 14:21:24 CEST 2009 Tobias Rautenkranz * cleanup: rename type= to smoke-type=. Mon May 11 14:05:00 CEST 2009 Tobias Rautenkranz * Visibility for C wrappers Mon May 11 14:02:40 CEST 2009 Tobias Rautenkranz * Cleanup: unpush does not need second argument. Mon May 11 13:07:39 CEST 2009 Tobias Rautenkranz * Prepare for overload resolution at compile time Fri Apr 17 17:26:55 CEST 2009 Tobias Rautenkranz * Experimental C++ style overload resolution. Tue Apr 14 16:23:24 CEST 2009 Tobias Rautenkranz * License Tue Apr 14 11:12:10 CEST 2009 Tobias Rautenkranz * Do not use :asdf in :smoke package Sun Apr 12 22:25:47 CEST 2009 Tobias Rautenkranz * fix cxx generic function documentation generation Sun Apr 12 21:53:53 CEST 2009 Tobias Rautenkranz * Export cxx operator functions. Sun Apr 12 21:53:26 CEST 2009 Tobias Rautenkranz * Support passing character arguments Sun Apr 12 16:43:33 CEST 2009 Tobias Rautenkranz * Support overloading by argument count for cxx: generic functions. Wed Apr 8 17:18:53 CEST 2009 Tobias Rautenkranz * Free translated return values (fix memleak) Wed Apr 8 17:18:07 CEST 2009 Tobias Rautenkranz * assert that binding exists Tue Apr 7 11:49:04 CEST 2009 Tobias Rautenkranz * cmucl support Mon Apr 6 13:48:20 CEST 2009 Tobias Rautenkranz * Tests on darcs record Sun Apr 5 17:36:29 CEST 2009 Tobias Rautenkranz * initial import diff -rN -u old-smoke/CMakeLists.txt new-smoke/CMakeLists.txt --- old-smoke/CMakeLists.txt 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/CMakeLists.txt 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,7 @@ +cmake_minimum_required(VERSION 2.6) + +project(smoke) + +add_subdirectory(src) + +include(UseDoxygen OPTIONAL) diff -rN -u old-smoke/COPYING new-smoke/COPYING --- old-smoke/COPYING 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/COPYING 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,676 @@ + + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. + diff -rN -u old-smoke/LICENSE new-smoke/LICENSE --- old-smoke/LICENSE 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/LICENSE 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,22 @@ +The software in this package is distributed under the GNU General Public +License (with a special exception described below). + +A copy of GNU General Public License (GPL) is included in this distribution, +in the file COPYING. + + Linking this library statically or dynamically with other modules is + making a combined work based on this library. Thus, the terms and + conditions of the GNU General Public License cover the whole + combination. + + As a special exception, the copyright holders of this library give you + permission to link this library with independent modules to produce an + executable, regardless of the license terms of these independent + modules, and to copy and distribute the resulting executable under + terms of your choice, provided that you also meet, for each linked + independent module, the terms and conditions of the license of that + module. An independent module is a module which is not derived from + or based on this library. If you modify this library, you may extend + this exception to your version of the library, but you are not + obligated to do so. If you do not wish to do so, delete this + exception statement from your version. diff -rN -u old-smoke/cl-smoke.smoke.asd new-smoke/cl-smoke.smoke.asd --- old-smoke/cl-smoke.smoke.asd 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/cl-smoke.smoke.asd 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,60 @@ +(defsystem :cl-smoke.smoke + :name :cl-smoke.smoke + :version (0 0 1) + :author "Tobias Rautenkranz" + :license "GPL with linking exception" + :description "Smoke bindings. Provides the base functionality to +implement bindings using the various Smoke modules." + :depends-on + (:cffi :closer-mop :alexandria :trivial-garbage :bordeaux-threads + #+(and sbcl unix) :sb-posix) + + :components + ((:module :src :components + ((:file "package") + (:file "using-type" :depends-on ("package")) + (:file "overload-resolution" :depends-on ("package" "smoke" "using-type")) + #+sbcl (:file "sb-optimize" :depends-on ("overload-resolution")) + (:file "smoke" :depends-on (:libsmoke :objects "clos")) + (:file "object-map" :depends-on (:objects :utils)) + (:file "class-map" :depends-on ("package")) + (:file "bindings" :depends-on ("package" :utils)) + (:file "cxx-method" :depends-on ("package")) + (:file "clos" :depends-on (:libsmoke "cxx-method" :objects + "object-map" "class-map" "bindings")) + (:file "smoke-to-clos" :depends-on ("clos" "overload-resolution")) + (:module :objects + :serial t + :depends-on (:libsmoke :utils "bindings") + :components + ((:file "object") (:file "enum" :depends-on ("object")) + (:file "type" :depends-on ("enum")) + (:file "method" :depends-on ("type")) + (:file "class" :depends-on ("method")) + (:file "instance" :depends-on ("class")) + (:file "stack" :depends-on ("instance")))) + (:module :libsmoke + :depends-on ("package") + :components + ((:file "smoke") + (:file "class" :depends-on ("smoke")) + (:file "stack" :depends-on ("class")) + (:file "method" :depends-on ("stack")) + (:file "type" :depends-on ("method")))) + (:module :utils + :depends-on ("package") + :components + ((:file "get-value") + #+(and sbcl unix) (:file "sbcl-bundle") + (:module :image :components + ((:file "image" :depends-on (:impl)) + (:module :impl + :components + (#+sbcl (:file "sbcl") + #+openmcl (:file "ccl") + #+(not (or sbcl openmcl)) + (:file "not-implemented"))))))))))) + +(defmethod perform ((operation test-op) (c (eql (find-system :cl-smoke.smoke)))) + (operate 'asdf:load-op :cl-smoke.qt.tests) + (operate 'asdf:test-op :cl-smoke.qt.tests)) diff -rN -u old-smoke/src/CMakeLists.txt new-smoke/src/CMakeLists.txt --- old-smoke/src/CMakeLists.txt 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/CMakeLists.txt 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1 @@ +add_subdirectory(libsmoke) diff -rN -u old-smoke/src/bindings.lisp new-smoke/src/bindings.lisp --- old-smoke/src/bindings.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/bindings.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,54 @@ +(in-package :smoke) + +(defstruct smoke-array + "A C array." + (pointer (null-pointer) :type foreign-pointer) + (length 0 :type (smoke-index 0))) + +(defstruct smoke-module + (pointer (null-pointer) :type foreign-pointer) + + (classes (make-smoke-array) :type smoke-array) + (methods (make-smoke-array) :type smoke-array) + (method-maps (make-smoke-array) :type smoke-array) + (method-names (make-smoke-array) :type smoke-array) + (types (make-smoke-array) :type smoke-array) + + (inheritance-list (null-pointer) :type foreign-pointer) + (argument-list (null-pointer) :type foreign-pointer) + (ambiguous-method-list (null-pointer) :type foreign-pointer)) + +(defvar *smoke-modules* (make-hash-table) + "All loaded Smoke modules.") + +(eval-on-save () + (clrhash *smoke-modules*)) + +(defmethod print-object ((smoke-module smoke-module) stream) + (if (null-pointer-p (smoke-module-pointer smoke-module)) + (call-next-method) + (print-unreadable-object (smoke-module stream :type t :identity t) + (princ (smoke-get-module-name (smoke-module-pointer smoke-module)) + stream)))) + +(defun init-smoke-module (module) + (let ((smoke (smoke-module-pointer module))) + (setf (gethash (pointer-address smoke) *smoke-modules*) + module) + (flet ((mk-array (array) + (make-smoke-array :pointer (cl-smoke-array smoke array) + :length (cl-smoke-array-size smoke array)))) + (setf (smoke-module-classes module) (mk-array :classes) + (smoke-module-methods module) (mk-array :methods) + (smoke-module-method-maps module) (mk-array :method-maps) + (smoke-module-method-names module) (mk-array :method-names) + (smoke-module-types module) (mk-array :types) + + (smoke-module-inheritance-list module) + (cl-smoke-array smoke :inheritance-list) + + (smoke-module-argument-list module) + (cl-smoke-array smoke :argument-list) + + (smoke-module-ambiguous-method-list module) + (cl-smoke-array smoke :ambiguous-method-list))))) diff -rN -u old-smoke/src/class-map.lisp new-smoke/src/class-map.lisp --- old-smoke/src/class-map.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/class-map.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,36 @@ +(in-package :smoke) + +(defvar *smoke-id-class-map* + (make-hash-table) + "Maps a Smoke module pointer - id pair to a class.") +;; FIXME disallow adding a class when threads are running or add a lock. + +(defun id-class-map (smoke) + (let ((value (gethash (pointer-address (smoke-module-pointer smoke)) + *smoke-id-class-map*))) + (assert value () "Unknown smoke module ~A." smoke) + value)) + +(defun (setf id-class-map) (new-value smoke) + (setf (gethash (pointer-address (smoke-module-pointer smoke)) + *smoke-id-class-map*) + new-value)) + +(defun add-id-class-map (smoke) + (setf (id-class-map smoke) (make-hash-table))) + +(defun add-id (smoke-class class) + "Associates the CLOS class CLASS with SMOKE-CLASS." + (setf (gethash (id smoke-class) (id-class-map (smoke smoke-class))) + class)) + +(defun find-smoke-class (class &optional (error-p t)) + "Returns the CLOS class for smoke-class CLASS." + (let* ((class (handler-case (real-class class) + (undefined-class (e) (when error-p (error e))))) + (ret (when class (gethash (id class) (id-class-map (smoke class)))))) + (when error-p + (assert (not (null ret)) + () + "The class ~A was not found." (name class))) + ret)) diff -rN -u old-smoke/src/clos-types.lisp new-smoke/src/clos-types.lisp --- old-smoke/src/clos-types.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/clos-types.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,48 @@ +(in-package :smoke) + +(defclass cxx::number () ()) + +(defclass cxx::rational (cxx::number) ()) + +(defclass cxx::int (cxx::rational) ()) +(defclass cxx::short (cxx::rational) ()) + + +(defclass cxx::real (cxx::number) ()) + +(defclass cxx::float (cxx::real) ()) +(defclass cxx::double (cxx::real) ()) + + +(defclass cxx::char () ()) +(defclass cxx::pointer () + ((next))) +(defclass cxx::const () + ((next))) + + +(defgeneric convert (from to)) + +(defmethod convert (from to) + (values nil nil)) + +(defun char->int (c) + (char-code c)) + +(defmethod convert ((from character) (to cxx::int)) + (values #'char->int 1)) + +(defmethod convert (from (to cxx::const)) + (call-next-method (const from) to)) + +(defmethod convert ((from cxx::const) (to cxx::const)) + (call-next-method (next from) (next to))) + +(defun float->int (f) + (round f)) + +(defmethod convert ((from float) (to cxx::int)) + (values #'float->int 1)) + +(defmethod convert ((from string) (to cxx::char))) +;(defmethod convert ((from string) (to qstring))) diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp --- old-smoke/src/clos.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/clos.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,569 @@ +(in-package #:smoke) + +(declaim (inline lispify)) +(defun lispify (name &optional (package nil)) + "Returns the interned symbol for name in Lisp style." + (declare (string name) + (optimize (speed 3))) + (if (null package) + (values (intern (cxx-to-lisp name))) + (values (intern (cxx-to-lisp name) package)))) + +(defmacro define-string-transform (name documentation &body states) + "Defines a function to transform a string." + (let ((output (gensym)) + (index (gensym)) + (length (gensym))) + `(defun ,name (input) + ,documentation + (declare (simple-string input) + (optimize (speed 3))) + ;; At least on sbcl 1.0.25.debian CONCATENATE is faster than + ;; VECTOR-PUSH-EXTEND. + (let ((,output "") + (,index 0) + (,length (length input)) + (char #\Null)) + (declare (base-char char)) + (macrolet ((next-char () + `(if (>= ,',index ,',length) + (return-from transform ,',output) + (progn + (setf char (aref input ,',index)) + (incf ,',index)))) + (go-next (tag) + `(progn (next-char) + (go ,tag))) + (append-char (char) + `(setf ,',output (concatenate 'string + ,',output + (string ,char))))) + (block transform + (tagbody + (next-char) ;; Get first char + ,@(reduce #'append + (mapcar #'(lambda (state) + (if (stringp (second state)) + `(,(first state) . ,(cddr state)) + state)) + states))))))))) + + +(define-string-transform lisp-to-cxx + "Converts LISP-STYLE to camelCase. +Note that (LISP-TO-CXX (CXX-TO-LIST SOME-STRING)) will not necessarily return +a string equal to SOME-STRING." + (default + "Down case, convert _ and dispatch." + (case char + (#\- (go-next camel-upcase)) + (#\. (go-next namespace)) + (t (append-char (char-downcase char)) + (go-next default)))) + (camel-upcase + "Convert camelCase to lisp-style." + (append-char char) + (go-next default)) + (namespace + "Convert . to ::" + (append-char #\:) + (append-char #\:) + (go default))) + +(define-string-transform cxx-to-lisp + "Returns camelCase STRING in lisp-style." + (begin + "Strip leading Q or K." + (case char + (#\K (go-next default)) + (#\Q (go-next default)) + (t (go default)))) + (default + "Up case, convert _ and dispatch." + (case char + (#\: (go-next namespace)) + (#\_ (append-char #\-) + (go-next default)) + (#\ (append-char #\-) ;; space (cast operators) + (go-next default)) + (t (append-char (char-upcase char)) + (if (lower-case-p char) + (go-next camel-case) + (go-next default))))) + (namespace + "C++ namespace separator" + (assert (eql #\: char)) + (append-char #\.) + (go-next default)) + (camel-case + "Convert camelCase to lisp-style." + (if (upper-case-p char) + (progn + (append-char #\-) + (append-char char) + (go-next default)) + (go default)))) + + +(defmethod print-object ((object smoke-standard-object) stream) + (if (slot-boundp object 'pointer) + (print-unreadable-object (object stream :type t) + (when (const-p object) + (princ "CONST " stream)) + (princ (pointer object) stream)) + (call-next-method))) + +(defclass smoke-standard-class (standard-class smoke-class) + () + (:documentation "A Smoke C++ class")) + +(defclass cxx:class (smoke-standard-class) + () + (:documentation "Metaclass to extend Smoke Objects.")) + +(defclass smoke-multi-superclass-mixin () + ((extra-objects :reader extra-objects + :initarg :extra-objects))) + +(defmethod closer-mop:validate-superclass ((class smoke-standard-class) + (superclass standard-class)) + t) + +(defmethod closer-mop:validate-superclass ((class cxx:class) + (superclass smoke-standard-class)) + t) + +;; Sets NIL superclass to SMOKE-STANDARD-OBJECT instead of the default +;; STANDARD-OBJECT. +(defun init-smoke-standard-class (class next-method + &rest args &key direct-superclasses + &allow-other-keys) + (apply next-method class + :direct-superclasses (or direct-superclasses + (list (find-class 'smoke-standard-object))) + args)) + +(defmethod initialize-instance :around ((class smoke-standard-class) &rest args) + (apply #'init-smoke-standard-class class #'call-next-method args)) + +(defmethod reinitialize-instance :around ((class smoke-standard-class) &rest args) + (apply #'init-smoke-standard-class class #'call-next-method args)) + + +(defun init-cxx-class (class next-method &rest args &key direct-superclasses + direct-default-initargs &allow-other-keys) + (assert (not (null direct-superclasses)) + (direct-superclasses) + "No superclass supplied for class ~A" class) + (let ((superclass (first direct-superclasses)) + (extra-superclasses (remove-if-not #'(lambda (class) + (typep class 'smoke-standard-class)) + (rest direct-superclasses)))) + (assert (typep superclass 'smoke-standard-class) + ((first direct-superclasses)) + "The first superclass ~A must be an subclass of an Smoke class." + class) + (assert (virtual-destructor-p superclass) + () + "The superclass ~A of ~A has a non virtual destructor." + superclass class) + (when extra-superclasses + (dolist (superclass extra-superclasses) + (unless (virtual-destructor-p superclass) + (cerror "Continue anyway" + "The superclass ~A of ~A has a non virtual destructor." + superclass class))) + (setf direct-superclasses + (append direct-superclasses + (list (find-class 'smoke-multi-superclass-mixin)))) + (push `(:extra-objects ,extra-superclasses ,#'(lambda () + extra-superclasses)) + direct-default-initargs)) + (apply + next-method class + :id (id superclass) + :smoke (smoke superclass) + :direct-superclasses direct-superclasses + :direct-default-initargs direct-default-initargs + args))) + +(defmethod reinitialize-instance :around ((class cxx:class) &rest args) + (apply #'init-cxx-class class #'call-next-method args)) + +(defmethod initialize-instance :around ((class cxx:class) &rest args) + (apply #'init-cxx-class class #'call-next-method args)) + +(defun smoke-class-symbols (classes) + (let ((class-symbols)) + (dolist (class classes class-symbols) + (if (external-p class) + (let ((real-class (find-smoke-class class nil))) + (when real-class + (push (class-name real-class) class-symbols))) + (push (lispify (name class)) class-symbols))))) + +(defun make-smoke-classes (package smoke) + "Constructs a lisp class in PACKAGE for each one in the Smoke module SMOKE." + (declare (optimize (speed 3))) + (let ((impl-package *package*) + (*package* (find-package package))) + (add-id-class-map smoke) + (map-classes + #'(lambda (class) + (unless (external-p class) + (with-simple-restart (skip "Skip generating class ~A" (name class)) + (let ((class-name + ;; There is a QGlobalSpace class per Smoke module. + ;; Put it in *package* and not PACKAGE to avoid + ;; clashes between multiple modules. + (if (string= "QGlobalSpace" (name class)) + (lispify "QGlobalSpace" impl-package) + (lispify (name class))))) + (add-id class + (closer-mop:ensure-class class-name + :direct-superclasses + (smoke-class-symbols + (smoke-class-direct-superclasses class)) + :id (id class) + :smoke (smoke class) + :metaclass 'smoke-standard-class)) + (when (eql (symbol-package class-name) *package*) + (export class-name)))))) + smoke))) + +(defclass smoke-gf (cxx-generic-function) + ((cxx-name :reader name :initarg :cxx-name + :type string + :documentation "The C++ name of the method.")) + (:metaclass closer-mop:funcallable-standard-class) + (:documentation "Smoke generic function.")) + +(declaim (inline smoke-class-of)) +(defun smoke-class-of (object) + "Returns the class of OBJECT or OBJECT iff it already is a class." + (declare (optimize (speed 3))) + (if (typep object 'smoke-class) + object + (class-of object))) + +;;; To speed up the startup +;;; ENSURE-METHOD is only called as needed. +(defmethod no-applicable-method ((gf smoke-gf) &rest args) + "Calls the smoke method." + (declare (dynamic-extent args) + (optimize (speed 3))) + (call-using-args (first args) (name gf) (rest args))) + +(defmethod add-method :after ((gf cxx-method-generic-function) method) + "Adds a method which calls the smoke method, to make call-next-method work." + (when (null (rest (closer-mop:generic-function-methods gf))) + (let ((lambda-list (closer-mop:method-lambda-list method))) + (closer-mop:ensure-method + gf + `(lambda ,lambda-list + (declare (optimize (speed 3))) + (call-using-args ,(first lambda-list) + (name ,(cxx-generic-function gf)) + (list ,@(rest lambda-list)))))))) + +(defcallback destructed :void + ((object-pointer :pointer)) + (declare (optimize (speed 3))) + (let ((object (get-object object-pointer))) + ;; The destructed callback can be the result of deleting the object + ;; in a finalizer. In that case the object is already removed from + ;; *object-map* when the callback is invoked. Thus OBJECT can be NIL. + (when object + (when (typep object 'smoke-multi-superclass-mixin) + (dolist (extra-object (extra-objects object)) + (unless (null-pointer-p (pointer extra-object)) + (remove-object (pointer extra-object)) + (delete-object extra-object)))) + (remove-finalizer object) + (remove-object object-pointer) + (setf (slot-value object 'pointer) (null-pointer))))) + +(declaim (inline argument-to-lisp)) +(defun argument-to-lisp (stack-item type) + ;; FIXME do not take ownership of stack allocated objects. + ;; It looks like there is no stack allocation in Qt virtual method signatures. + (type-to-lisp stack-item type)) + +(defun stack-to-args (stack arg &optional (args nil)) + "Returns the arguments in STACK, where ARG is the type +of the first argument, as an list of Lisp objects." + (if (end-p arg) + (reverse args) + (stack-to-args (inc-pointer stack + (foreign-type-size 'smoke-stack-item)) + (next arg) + (cons (argument-to-lisp (mem-ref stack 'smoke-stack-item) + arg) + args)))) + +(defun convert-argument (argument type &optional disown) + "Returns ARGUMENT converted to TYPE and removes the ownership when +it is passed on the stack." + (flet ((disown (object) + (remove-finalizer object) + (when (typep object 'smoke-standard-object) + (remove-object (pointer object))))) + (let ((rank (get-conversion-sequence argument type nil))) + (if (null rank) + (let ((rank (get-conversion-sequence argument type t))) + (if (null rank) + (error "Can not convert the argument ~S to ~A." + argument (name type)) + (let ((ret (funcall (conversion-function-name rank) + argument))) + (when (and disown (stack-p type)) + (disown ret)) + ret))) + (prog1 (funcall (conversion-function-name rank) argument) + (when (and disown (stack-p type)) + (disown argument))))))) + +(defun put-returnvalue (stack value type object) + (unless (void-p type) + (let ((stack (make-call-stack stack))) + (setf (call-stack-top stack) (call-stack-pointer stack)) + (let ((converted-value (convert-argument value type t))) + (push-smoke-stack stack converted-value (type-id type)))))) + +(defun get-gf-for-method (smoke-method) + (declare (smoke-method smoke-method) + (optimize (speed 3))) + (symbol-function (lispify (name smoke-method) "CXX"))) + +;; Receive virtual function calls. +(defcallback dispatch-method :boolean + ((method smoke-index) + (object-ptr :pointer) + (stack smoke-stack) + (abstract :boolean)) + (declare (optimize (speed 3))) + (let ((object (get-object object-ptr))) + ;; The Lisp OBJECT can be gc'ed but we might still receive a + ;; QObject destructed event when the C++ instance is deleted in + ;; the finalizer. Thus OBJECT might be NIL. + (unless (null object) + (let* ((method (make-smoke-method + :smoke (smoke (class-of object)) + :id method))) + (loop + (restart-case + (return-from dispatch-method + (let ((gf (get-gf-for-method method))) + (declare (function gf)) + (if (null (gf-methods gf)) + (progn + (when abstract + (error "Abstract method ~A of ~A called." + (method-declaration method) object)) + nil) + (if object + (progn + (put-returnvalue + stack + (apply gf object + (stack-to-args + (inc-pointer stack (foreign-type-size + 'smoke-stack-item)) + (get-first-argument method))) + (return-type method) object) + t) + nil)))) + ;; Restarts to prevent stack unwinding across the C++ stack. + (call-default () + :report (lambda (stream) + (declare (stream stream)) + (format stream + "Call default implementation ~A instead." + method)) + :test (lambda (condition) + (declare (ignore condition)) + (not abstract)) + (return-from dispatch-method nil)) + (use-returnvalue (return-value) + :report (lambda (stream) + (declare (stream stream)) + (format stream "Supply a return value for ~A." + (method-declaration method))) + :test (lambda (condition) + (declare (ignore condition)) + (not (void-p (return-type method)))) + :interactive (lambda () + (format *query-io* "~&Enter a new return value: ") + (multiple-value-list (eval (read *query-io*)))) + (put-returnvalue stack return-value + (return-type method) + (get-object object-ptr)) + (return-from dispatch-method t)) + (return () + :report (lambda (stream) + (declare (stream stream)) + (format stream "Return void for ~A." + (method-declaration method))) + :test (lambda (condition) + (declare (ignore condition)) + (void-p (return-type method))) + (return-from dispatch-method (values))) + (retry () + :report (lambda (stream) + (declare (stream stream)) + (format stream "Try again calling ~A." + (method-declaration method)))))) + nil)))) + +;;FIXME use CHANGE-CLASS instead? +(defgeneric cast (object class) + (declare (optimize (speed 3))) + (:documentation "Returns a pointer of type CLASS to the C++ object of OBJECT.") + (:method (object class) + (declare (optimize (speed 3))) + (assert (derived-p (class-of object) class) + () + "Can not cast object ~A of class ~A to class ~A." + object (name (class-of object)) (name class)) + (smoke-cast (smoke-module-pointer (smoke (class-of object))) (pointer object) + (id (class-of object)) + (smoke-class-id (smoke-module-pointer (smoke (class-of object))) + (name-pointer class)))) + (:method ((object smoke-multi-superclass-mixin) class) + (if (derived-p (class-of object) class) + (call-next-method) + (let ((extra-object (find-if #'(lambda (o) + (derived-p (class-of o) class)) + (extra-objects object)))) + (assert extra-object + () + "Can not cast object ~A to class ~A." + object (name class)) + (cast extra-object class))))) + +(defun upcast (object class) + (assert (derived-p class (class-of object)) + () + "Can not upcast object ~A of class ~A to class ~A." + object (name (class-of object)) (name class)) + (smoke-cast (smoke-module-pointer (smoke class)) (pointer object) + (id (class-of object)) (id (real-class class)))) + + +;; The constructor name is the name of the class minus any namespace parts. +(defun constructor-name (class) + (declare (optimize (speed 3))) + (let* ((name (the simple-string (name class))) + (name-start (search "::" name :from-end t))) + (if name-start + (subseq name (+ name-start 2)) + name))) + +(defun call-constructor (class arguments) + (multiple-value-bind (method sequence) + (#-sbcl find-best-viable-function + #+sbcl find-best-viable-function-cached + (constructor-name class) + arguments + class nil) + (when (null method) + (error "No constructor for class ~A with +the arguments ~S." class arguments)) + (pointer-call method (null-pointer) + (mapcar #'(lambda (conversion argument) + (funcall conversion argument)) + sequence arguments)))) + +(defmethod initialize-instance :after ((object smoke-standard-object) + &key args + (arg0 nil arg0p) + (arg1 nil arg1p) + (arg2 nil arg2p) + (arg3 nil arg3p) + &allow-other-keys) + "Initializes a Smoke object. Calls its constructor with the arguments supplied +by the key :ARGS and sets the smoke binding." + (declare (optimize (speed 3))) + (assert (not (and (slot-boundp object 'pointer) + (not (null args)))) + ((slot-value object 'pointer) args) + "Pointer ~A bound and constructor argument :ARGS ~S supplied." + (slot-value object 'pointer) args) + (unless (slot-boundp object 'pointer) + (if arg0p + (setf (slot-value object 'pointer) + (call-constructor (class-of object) + (cond + (arg3p (list arg0 arg1 arg2 arg3)) + (arg2p (list arg0 arg1 arg2)) + (arg1p (list arg0 arg1)) + (t (list arg0))))) + (setf (slot-value object 'pointer) + (call-constructor (class-of object) args))) + (set-binding object) + (take-ownership object) + (add-object object))) + +(defun construct-extra-objects (object extra-objects) + (loop for class in extra-objects + collect (let ((extra-object (make-instance (first extra-objects) + :pointer (call-constructor (first extra-objects) + nil)))) + (set-binding extra-object) + (setf (get-object (pointer extra-object)) object) + extra-object))) + +(defmethod initialize-instance :after ((object smoke-multi-superclass-mixin) + &key args) + (setf (slot-value object 'extra-objects) + (construct-extra-objects object (extra-objects object)))) + +(defmethod make-finalize ((object smoke-multi-superclass-mixin)) + (let ((pointer (pointer object)) + (extra-objects (extra-objects object)) + (class (class-of object))) + #'(lambda () + (declare (optimize (speed 3))) + (handler-case (progn + (delete-pointer pointer class) + (dolist (object extra-objects) + (delete-object object))) + (error (condition) + (report-finalize-error condition 't (name class) pointer)))))) + +(defmethod instance-to-lisp (pointer class type) + (declare (type smoke-standard-class class) + (optimize (speed 3))) + (let ((ret (make-instance class :pointer pointer + :const-p (const-p type)))) + (when (stack-p type) + (take-ownership ret) + (add-object ret)) + ret)) + +(defun keep-wrapper (object new-owner) + (declare (type smoke-standard-object object) + (optimize (speed 3))) + (when (member object (owned-objects new-owner)) + (cerror "Ignore" "~A has already been added to ~A." + object new-owner)) + (push object (owned-objects new-owner))) + +(declaim (inline remove-wrapper-object)) +(defun remove-wrapper-object (object owner) + (remove object (owned-objects owner))) + +(defun transfer-ownership-to (object new-owner) + "Transfers the ownership of OBJECT to C++." + (declare (optimize (speed 3))) + (remove-finalizer object) + (if (virtual-destructor-p (class-of object)) + (keep-wrapper object new-owner) + (remove-object (pointer object)))) + +(defun take-ownership (object &optional current-owner) + "Assigns the ownership of OBJECT to Lisp. i.e.: +cl-smoke is responsible for deleting the object." + (when current-owner + (remove-wrapper-object object current-owner)) + (set-finalizer object)) diff -rN -u old-smoke/src/cxx-method.lisp new-smoke/src/cxx-method.lisp --- old-smoke/src/cxx-method.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/cxx-method.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,167 @@ +(in-package :smoke) + +(defclass cxx-generic-function (standard-generic-function) + ((gf-methods :initform nil :type list + :accessor gf-methods + :documentation "gf for different argument counts.")) + (:metaclass closer-mop:funcallable-standard-class) + (:documentation "gf that can be overloaded by argument count.")) + +(defclass cxx-method-generic-function (standard-generic-function) + ((generic-function :accessor cxx-generic-function + :initarg :cxx-generic-function + :type cxx-generic-function + :documentation "Contains the generic function.")) + (:metaclass closer-mop:funcallable-standard-class) + (:documentation "Generic function of a specify argument count.")) + + + +(defun make-lambda (argument-count) + "Returns a lambda expression for ARGUMENT-COUNT arguments." + (declare ((integer 0) argument-count)) + (loop for i from 0 below argument-count + collect (intern (format nil "A~A" i)))) + +(defun argument-count (generic-function) + "Returns the number of arguments to GENERIC-FUNCTION." + (length (closer-mop:generic-function-lambda-list generic-function))) + +(defun find-generic-function-by-argument-count (cxx-generic-function argument-count) + "Returns the generic function of CXX-GENERIC-FUNCTION that takes +ARGUMENT-COUNT arguments, or false when no such function exists." + (declare (cxx-generic-function cxx-generic-function) + ((integer 0) argument-count) + (values (or cxx-method-generic-function null))) + (find-if #'(lambda (gf) + (= argument-count (argument-count gf))) + (gf-methods cxx-generic-function))) + +(defun cxx-method-generic-function-name (cxx-generic-function argument-count) + (let ((*package* (find-package :cxx))) + (symbolicate (closer-mop:generic-function-name cxx-generic-function) + #\/ (write-to-string argument-count)))) + +(defun ensure-gf-by-argument-count (cxx-generic-function argument-count) + "Returns the generic-function of CXX-GENERIC-FUNCTION that takes +ARGUMENT-COUNT arguments. When none exists, one is created." + (declare (cxx-generic-function cxx-generic-function) + ((integer 0) argument-count)) + (or (find-generic-function-by-argument-count cxx-generic-function + argument-count) + (let* ((name (cxx-method-generic-function-name cxx-generic-function + argument-count)) + (gf (make-instance 'cxx-method-generic-function + :name name + :cxx-generic-function cxx-generic-function + :lambda-list (make-lambda argument-count)))) + (setf (fdefinition name) gf) + (push gf (gf-methods cxx-generic-function)) + gf))) + +(defun method-argument-count (method) + "Returns the number of arguments of METHOD." + (length (closer-mop:method-lambda-list method))) + +(defun lambda-list-keywords-p (lambda-list) + "Returns true when LAMBDA-LIST contains a lambda list keyword +and false otherwise." + (not (null (intersection lambda-list-keywords lambda-list)))) + +(defun check-cxx-method-argument-list (method) + "Signals an error when METHOD contains lambda list keywords." + (assert (not (lambda-list-keywords-p (closer-mop:method-lambda-list method))) + () + "The method ~A must not contain lambda list keywords." method)) + +(defun push-method (method cxx-generic-function) + "Adds METHOD to a cxx-method-generic-function of CXX-GENERIC-FUNCTION." + (declare (optimize (speed 3))) + (let ((generic-function (ensure-gf-by-argument-count + cxx-generic-function + (method-argument-count method)))) + (add-method generic-function method))) + +(defun unpush-method (method) + "Removes METHOD from its generic-function." + (let ((generic-function (closer-mop:method-generic-function method))) + (when generic-function + (remove-method generic-function method)))) + ;(when (null (closer-mop:generic-function-methods generic-function)) + ; TODO + +(defmethod no-applicable-method ((gf cxx-method-generic-function) &rest args) + (apply #'no-applicable-method (cxx-generic-function gf) args)) + +#+sbcl +(defmethod closer-mop:compute-applicable-methods-using-classes ((gf cxx-generic-function) classes) + (let ((gf2 (find-generic-function-by-argument-count gf (length classes)))) + (if gf2 + (values (list gf2) t) + (values nil t)))) + +(defmethod closer-mop:compute-discriminating-function ((cxx-generic-function cxx-generic-function)) + (declare (optimize (speed 3))) + ;; Special case no methods, since it will apply to all cxx generic functions + ;; on start up and the eval stuff is slower. + (if (null (gf-methods cxx-generic-function)) + #'(lambda (&rest args) + (apply #'no-applicable-method cxx-generic-function args)) + (eval + `#'(lambda (&rest args) + (case (length args) + ,@(loop for gf in (gf-methods cxx-generic-function) + collect `(,(argument-count gf) + (apply ,gf args))) + (t (apply #'no-applicable-method ,cxx-generic-function args))))))) + + +#+sbcl +(defmethod compute-applicable-methods ((gf cxx-generic-function) arguments) + ;; -using-classes only cares about the number of arguments; + ;; thus no the to actually pass the classes. + (closer-mop:compute-applicable-methods-using-classes gf arguments)) + +(defun update-method (generic-function action method) + "Updates GENERIC-FUNCTION when METHOD has been added or removed; +and updates the dependents." + (declare (generic-function generic-function) + ((member add-method remove-method) action) + (standard-method method) + (optimize (speed 3))) + (closer-mop:set-funcallable-instance-function + generic-function + (closer-mop:compute-discriminating-function generic-function)) + (closer-mop:map-dependents + (class-of generic-function) + #'(lambda (dependent) + (closer-mop:update-dependent (class-of generic-function) + dependent + action method)))) + +(defmethod add-method ((gf cxx-generic-function) method) + (declare (optimize (speed 3))) + (push-method method gf) + (update-method gf 'add-method method)) + +(defmethod remove-method ((gf cxx-generic-function) method) + (unpush-method method) + (update-method gf 'remove-method method)) + +#| +(defun cxx-dispatch-compiler-macro (cxx-generic-function) + "Returns a compiler-macro form for CXX-GENERIC-FUNCTION that +precomputes the dispatching for the argument count, if possible." + ;; FIXME only applies when a defmethod with the right argument count + ;; has been defined, which is almost never. + `(define-compiler-macro ,(closer-mop:generic-function-name cxx-generic-function) + (&whole form object &rest args) + (let ((name (cxx-method-generic-function-name (fdefinition (first form)) + (1+ (length args))))) + (if (fboundp name) + `(,name ,object ,@args) + form)))) + +(defmethod initialize-instance :after ((gf cxx-generic-function) &key &allow-other-keys) + (eval (cxx-dispatch-compiler-macro gf))) +|# diff -rN -u old-smoke/src/libsmoke/CMakeLists.txt new-smoke/src/libsmoke/CMakeLists.txt --- old-smoke/src/libsmoke/CMakeLists.txt 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/libsmoke/CMakeLists.txt 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,39 @@ +find_package(Qt4 REQUIRED) +set(QT_DONT_USE_QTGUI true) +include(${QT_USE_FILE}) + +include(CheckCXXCompilerFlag) +check_cxx_compiler_flag("-fvisibility=hidden" CXX_VISIBILITY) +if(CXX_VISIBILITY) + set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -fvisibility=hidden -fvisibility-inlines-hidden") +endif(CXX_VISIBILITY) + + +# FIXME look for smoke.h +find_library(smokebase_LIB smokebase) +if (smokebase_LIB) + set(smokebase_FOUND TRUE) +endif (smokebase_LIB) + +if (smokebase_FOUND) + message(STATUS "Found smokebase: ${smokebase}") +else (smokebase_FOUND) + message(FATAL_ERROR "Could not find smokebase") +endif (smokebase_FOUND) + + +set(SMOKE_C_SOURCES smoke.cpp smokebinding.cpp) +add_library(clsmoke SHARED ${SMOKE_C_SOURCES}) +target_link_libraries(clsmoke ${QT_LIBRARIES} ${smokebase_LIB}) +set_target_properties(clsmoke + PROPERTIES + SOVERSION "0.0" + VERSION "0.0.1") + +add_library(clsmokeutil SHARED smoke_util.cpp) +set_target_properties(clsmokeutil + PROPERTIES + SOVERSION "0.0" + VERSION "0.0.1") + +install(TARGETS clsmoke clsmokeutil DESTINATION lib) diff -rN -u old-smoke/src/libsmoke/cl_smoke.h new-smoke/src/libsmoke/cl_smoke.h --- old-smoke/src/libsmoke/cl_smoke.h 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/libsmoke/cl_smoke.h 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,50 @@ +#ifndef CL_SMOKE_H +#define CL_SMOKE_H + +#include + +#if defined _WIN32 || defined __CYGWIN__ + #define CL_SMOKE_EXPORT __declspec(dllexport) +#else + #if __GNUC__ >= 4 + #define CL_SMOKE_EXPORT __attribute__((visibility("default"))) + #else + #define CL_SMOKE_EXPORT + #endif +#endif + +/** @brief cl-smoke binding namespace. */ +namespace cl_smoke +{ +class Binding; + +/** The arrays of the Smoke module */ +enum cl_smoke_module_array +{ + classes, + methods, + method_maps, + method_names, + types, + inheritance_list, + argument_list, + ambiguous_method_list +}; + +/** A Binding */ +typedef void* smoke_binding; + +/** Casts the void pointer smoke to the Smoke class. + * @param smoke the Smoke module + * + * @return pointer to the Smoke module. + */ +static inline +Smoke* +get_smoke(void* smoke) +{ + return static_cast(smoke); +} +} // namespace cl_smoke + +#endif // CL_SMOKE_H diff -rN -u old-smoke/src/libsmoke/class.lisp new-smoke/src/libsmoke/class.lisp --- old-smoke/src/libsmoke/class.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/libsmoke/class.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,44 @@ +(in-package #:smoke) + +(defcenum smoke-class-flags + "Class properties" + (:constructor #x01) + (:copy-constructor #x02) + (:virtual-destructor #x04) + (:namespace #x08) + (:undefined #x10)) + +(defcstruct smoke-class + "Describe a class" + (name :string) + (external cxx-bool) + (parents smoke-index) + (class-function :pointer) + (enum-function :pointer) + (flags :unsigned-short) + (size :unsigned-int)) + +(defcfun (smoke-find-class "cl_smoke_find_class") :void + (m :pointer smoke-module-index) + (name :string)) + +(declaim (inline smoke-class-id)) +(defcfun (smoke-class-id "cl_smoke_class_id") smoke-index + (smoke :pointer) + (name :string)) + +(defcfun (smoke-get-class "cl_smoke_get_class") (:pointer smoke-class) + (smoke :pointer) + (class smoke-index)) + +(defcfun (smoke-is-derived-from "cl_smoke_is_derived_from") :boolean + (smoke :pointer) + (class smoke-index) + (smoke-base :pointer) + (base-class smoke-index)) + +(defcfun (smoke-cast "cl_smoke_cast") :pointer + (smoke :pointer) + (object :pointer) + (from smoke-index) + (to smoke-index)) diff -rN -u old-smoke/src/libsmoke/method.lisp new-smoke/src/libsmoke/method.lisp --- old-smoke/src/libsmoke/method.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/libsmoke/method.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,41 @@ +(in-package #:smoke) + +(defcenum smoke-method-flags + "Method flags" + (:static #x01) + (:const #x02) + (:copy-constructor #x04) + (:internal #x08) + (:enum #x10) + (:constructor #x20) + (:destructor #x40) + (:protected #x80) + (:attribute #x100) + (:property #x200) + (:virtual #x400) + (:purevirtual #x800) + (:signal #x1000) + (:slot #x2000)) + +(defcstruct smoke-method + "Describe a method" + (class smoke-index) + (name smoke-index) + (arguments smoke-index) + (num-args :unsigned-char) + (flags :unsigned-short) + (return-type smoke-index) + (method smoke-index)) + +(defcstruct smoke-method-map + "Maps a munged method." + (class-id smoke-index) + (name smoke-index) + (method smoke-index)) + +(declaim (inline smoke-find-method)) +(defcfun (smoke-find-method "cl_smoke_find_method") :void + (m :pointer smoke-module-index) + (smoke :pointer) + (class smoke-index) + (method :string)) diff -rN -u old-smoke/src/libsmoke/smoke.cpp new-smoke/src/libsmoke/smoke.cpp --- old-smoke/src/libsmoke/smoke.cpp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/libsmoke/smoke.cpp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,240 @@ +#include "cl_smoke.h" +#include "smokebinding.h" + +#include +#include + +/** @file + * @brief C wrapper the Smoke bindings. + */ + +using namespace cl_smoke; + +extern "C" { + +/** Creates a new Smoke binding. + * The binding is allocated on the heap an can be freed with smoke_destruct(). + * When method dispatching is not needed, a null pointer can be passed for @a dispatch. + * @related cl_smoke::Binding + * @related cl_smoke::NoDispatchBinding + * @related cl_smoke_destruct_binding + * @param smoke pointer to a Smoke module instance + * @param destruct callback for object destruction + * @param dispatch method dispatch callback + * + * @return a pointer to a new Smoke binding. + */ +CL_SMOKE_EXPORT smoke_binding +cl_smoke_construct_binding(void* destruct, void* dispatch) +{ + if (NULL == dispatch) + return new NoDispatchBinding(reinterpret_cast(destruct)); + else + return new Binding(reinterpret_cast(destruct), + reinterpret_cast(dispatch)); +} + +/** Deletes the Smoke binding. + * @related cl_smoke_construct_binding + */ +CL_SMOKE_EXPORT void +cl_smoke_destruct_binding(smoke_binding binding) +{ + // Destructor is virtual; thus we can do this. + delete static_cast(binding); +} + +/** Gets a Smoke module name. + * @param smoke the Smoke module + * + * @return the module name + */ +CL_SMOKE_EXPORT const char* +cl_smoke_get_module_name(void* smoke) +{ + return get_smoke(smoke)->moduleName(); +} + + +/** Returns the pointer to the array @a array of @a smoke. + * @param smoke the Smoke module + * @param array the array type + * + * @return a pointer to the array + */ +CL_SMOKE_EXPORT void* +cl_smoke_array(void* smoke, cl_smoke_module_array array) +{ + switch (array) + { + case classes: + return get_smoke(smoke)->classes; + case methods: + return get_smoke(smoke)->methods; + case method_maps: + return get_smoke(smoke)->methodMaps; + case method_names: + return get_smoke(smoke)->methodNames; + case types: + return get_smoke(smoke)->types; + case inheritance_list: + return get_smoke(smoke)->inheritanceList; + case argument_list: + return get_smoke(smoke)->argumentList; + case ambiguous_method_list: + return get_smoke(smoke)->ambiguousMethodList; + } + qFatal("cl_smoke_array(): Unknown smoke_array %d", array); +} + +/** Returns the size of the array @a array of @a smoke. + * The size if inclusive the bound. + * @param smoke the Smoke module + * @param array the array type + * + * @return the size + */ +CL_SMOKE_EXPORT Smoke::Index +cl_smoke_array_size(void* smoke, cl_smoke_module_array array) +{ + switch (array) + { + case classes: + return get_smoke(smoke)->numClasses; + case methods: + return get_smoke(smoke)->numMethods; + case method_maps: + return get_smoke(smoke)->numMethodMaps; + case method_names: + return get_smoke(smoke)->numMethodNames; + case types: + return get_smoke(smoke)->numTypes; + case inheritance_list: + case argument_list: + case ambiguous_method_list: + qFatal("cl_smoke_array_size(): size of %d not known.", array); + } + qFatal("cl_smoke_array_size(): Unknown smoke_array %d.", array); +} + +/////////////////////////// +/// Class +/////////////////////////// + +/** Finds a class. + * @param c pointer to write the result to + * @param name the name of the class + */ +CL_SMOKE_EXPORT void +cl_smoke_find_class(Smoke::ModuleIndex* c, const char* name) +{ + *c = Smoke::findClass(name); +} + +/** Gets the class ID for a Smoke module. + * @param smoke the Smoke module + * @param name the class name + * + * @return the class ID in the supplied Smoke module + */ +CL_SMOKE_EXPORT Smoke::Index +cl_smoke_class_id(void* smoke, const char* name) +{ + Smoke::ModuleIndex m = get_smoke(smoke)->idClass(name, true); + Q_ASSERT(m.smoke == smoke); + + return m.index; +} + +/** Gets a class + * @param smoke the smoke binding + * @param class_index the index of the class + * + * @return A pointer to the class into the array of class structs + */ +CL_SMOKE_EXPORT const struct Smoke::Class* +cl_smoke_get_class(void* smoke, Smoke::Index class_index) +{ + Q_ASSERT(class_index >= 0 && class_index <= get_smoke(smoke)->numClasses); + return &get_smoke(smoke)->classes[class_index]; +} + +/** Determines werter a class is from a base class. + * @param smoke the Smoke module of @a class_index + * @param class_index the class index + * @param smoke_base the Smoke module of the base class @a base_index + * @param base_index the index of the base class + * + * @return Returns 0 when the class is not derived from the base class and nonzero value otherwise. + */ +CL_SMOKE_EXPORT int +cl_smoke_is_derived_from(void* smoke, Smoke::Index class_index, void* smoke_base, + Smoke::Index base_index) +{ + Q_ASSERT(!cl_smoke_get_class(smoke, class_index)->external); + Q_ASSERT(!cl_smoke_get_class(smoke_base, base_index)->external); + + return Smoke::isDerivedFrom(get_smoke(smoke), class_index, + get_smoke(smoke_base), base_index); +} + +////////////////////////////// +/// Method +////////////////////////////// + +/** Finds a method of a class. + * @param m pointer to write the result to + * @param smoke the smoke module + * @param class_index index of the class + * @param method_name method name + */ +CL_SMOKE_EXPORT void +cl_smoke_find_method(Smoke::ModuleIndex* m, void* smoke, + Smoke::Index class_index, const char* method_name) +{ + Q_ASSERT(class_index >= 0 && class_index <= get_smoke(smoke)->numClasses); + + const char* class_name = get_smoke(smoke)->className(class_index); + Smoke::ModuleIndex id_class(get_smoke(smoke), class_index); + + Smoke::ModuleIndex id_method_name = get_smoke(smoke)->findMethodName(class_name, method_name); + *m = get_smoke(smoke)->findMethod(id_class, id_method_name); + + if(m->index > 0) + m->index = m->smoke->methodMaps[m->index].method; +} + +/////////////////////////// +/// Type +////////////////////////// + +/** Gets the index of a type. + * @param smoke the Smoke module + * @param name the types name + * + * @return the index of the type + */ +CL_SMOKE_EXPORT Smoke::Index +cl_smoke_find_type(void* smoke, const char* name) +{ + return get_smoke(smoke)->idType(name); +} + +/** Casts an object. + * @param smoke the Smoke module + * @param object the object + * @param from the class index of @a object + * @param to the class index to cast to + * + * @return the casted object + */ +CL_SMOKE_EXPORT void* +cl_smoke_cast(void* smoke, void* object, Smoke::Index from, Smoke::Index to) +{ + Q_ASSERT(from > 0 && from <= get_smoke(smoke)->numClasses); + Q_ASSERT(to > 0 && to <= get_smoke(smoke)->numClasses); + + return get_smoke(smoke)->cast(object, from, to); +} + +} // extern "C" diff -rN -u old-smoke/src/libsmoke/smoke.lisp new-smoke/src/libsmoke/smoke.lisp --- old-smoke/src/libsmoke/smoke.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/libsmoke/smoke.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,72 @@ +(in-package #:smoke) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (define-foreign-library libclsmoke + (:darwin "libclsmoke.dylib") + (:unix "libclsmoke.so") + (t (:default "libclsmoke"))) + (define-foreign-library libclsmokeutil + (:darwin "libclsmokeutil.dylib") + (:unix "libclsmokeutil.so") + (t (:default "libclsmokeutil"))) + (use-foreign-library libclsmoke)) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (use-foreign-library libclsmokeutil) + (defcfun (smoke-sizeof-bool "cl_smoke_sizeof_bool") :int) + (defun cffi-bool-type () + "Returns a cffi unsigned int type with the same size as a C++ bool." + (load-foreign-library 'libclsmokeutil) + (intern (format nil "UINT~A" (* 8 (smoke-sizeof-bool))) + (find-package :keyword))) + + (defmacro defcxxbool () + `(defctype cxx-bool (:boolean ,(cffi-bool-type))))) + +(defcxxbool) + +;(close-foreign-library 'libclsmokeutil) + +(defctype smoke-binding :pointer + "A Smoke binding") + +(defctype smoke-index :short + "An index") + +(deftype smoke-index (&optional (lower -32768) (upper 32767)) + "Smoke index." + `(integer ,lower ,upper)) + +(defcfun (smoke-construct-binding "cl_smoke_construct_binding") smoke-binding + (destruct :pointer) + (dispatch :pointer)) + +(defcfun (smoke-destruct-destruct "cl_smoke_destruct_binding") :void + (smoke smoke-binding)) + +;; Smoke::ModuleIndex is a POD-struct. +;; Thus we can treat it as a C struct. +(defcstruct smoke-module-index + (smoke :pointer) + (index smoke-index)) + +(defcfun (smoke-get-module-name "cl_smoke_get_module_name") :string + (smoke :pointer)) + +(defcenum cl-smoke-array + :classes + :methods + :method-maps + :method-names + :types + :inheritance-list + :argument-list + :ambiguous-method-list) + +(defcfun cl-smoke-array :pointer + (smoke :pointer) + (array cl-smoke-array)) + +(defcfun cl-smoke-array-size smoke-index + (smoke :pointer) + (array cl-smoke-array)) diff -rN -u old-smoke/src/libsmoke/smoke_util.cpp new-smoke/src/libsmoke/smoke_util.cpp --- old-smoke/src/libsmoke/smoke_util.cpp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/libsmoke/smoke_util.cpp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,27 @@ +#if defined _WIN32 || defined __CYGWIN__ + #define CL_SMOKE_EXPORT __declspec(dllexport) +#else + #if __GNUC__ >= 4 + #define CL_SMOKE_EXPORT __attribute__((visibility("default"))) + #else + #define CL_SMOKE_EXPORT + #endif +#endif + +/** @file + * \@brief Utility functions + */ + +extern "C" { + +/** Gets the size of the C++ bool type in bytes. + * + * @return the size of bool + */ +CL_SMOKE_EXPORT int +cl_smoke_sizeof_bool() +{ + return sizeof(bool); +} + +} // extern "C" diff -rN -u old-smoke/src/libsmoke/smokebinding.cpp new-smoke/src/libsmoke/smokebinding.cpp --- old-smoke/src/libsmoke/smokebinding.cpp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/libsmoke/smokebinding.cpp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,105 @@ +#include "smokebinding.h" + +#include +#include + +namespace cl_smoke +{ + +/** @class NoDispatchBinding + * @brief The Smoke binding for classes we need no dispatching. + * This saves some overhead, since it does not call into Lisp. + * Idea stolen from CommonQt ;) + * + * Dispatches for non extended classes (not of class CXX:CLASS) are between + * 20% - 40% (for qt.examples:colliding-mice - qt.examples:class-browser). (18 February 2010) + */ + +/** @typedef NoDispatchBinding::destructed + * Callback when a Smoke object is destructed. + * + * @param class_index Index of the object's class. + * @param object pointer to the object + */ + +/** Constructor. + * @param destruct destruct callback + */ +NoDispatchBinding::NoDispatchBinding(destructed destruct) + : SmokeBinding(NULL), + destruct(destruct) +{ + Q_ASSERT(destruct); +} + +/** Invoked when a Smoke object is destructed. */ +void +NoDispatchBinding::deleted(Smoke::Index, void *object) +{ + destruct(object); +} + +/** Invoked when a Smoke method gets called. */ +bool +NoDispatchBinding::callMethod(Smoke::Index method, void* object, + Smoke::Stack stack, bool abstract) +{ + Q_ASSERT(!abstract); + return false; +} + +/** + * @todo Returning a const char* would be better + */ +char* +NoDispatchBinding::className(Smoke::Index classId) +{ + qFatal("className() Not implemented"); +} + +/** @function NoDispatchBinding::get_smoke() + * Gets the Smoke instance associated with the binding. + * @return a pointer to the Smoke instance + */ + +/** @class Binding + * @brief The Smoke binding. + */ + +/** @typedef Binding::dispatch_method + * Callback when a Smoke method gets called. + * + * @param binding Smoke binding of @a object + * @param method index of the method + * @param object the object for which the method is called + * @param args the arguments to the method + * @param abstract @c true when the method is abstract and @c false otherwise + * + * @return @c true when the method call was handled and @c false + * when the default method shall be invoked. + */ + +/** Constructor. + * @param destruct destruct callback + * @param dispatch method dispatch callback + */ +Binding::Binding(destructed destruct, dispatch_method dispatch) + : NoDispatchBinding(destruct), + dispatch(dispatch) +{ + Q_ASSERT(dispatch); +} + + +/** Invoked when a Smoke method gets called. */ +bool +Binding::callMethod(Smoke::Index method, void* object, + Smoke::Stack stack, bool abstract) +{ + int ret = dispatch(method, object, stack, abstract); + Q_ASSERT( !abstract || ret ); + + return ret; +} + +} // namespace cl_smoke diff -rN -u old-smoke/src/libsmoke/smokebinding.h new-smoke/src/libsmoke/smokebinding.h --- old-smoke/src/libsmoke/smokebinding.h 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/libsmoke/smokebinding.h 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,50 @@ +#ifndef SMOKEBINDING_H +#define SMOKEBINDING_H + +#include + +namespace cl_smoke +{ + +class NoDispatchBinding : public SmokeBinding +{ + public: + typedef void (*destructed)(void* object); + + NoDispatchBinding(destructed destruct); + + virtual void + deleted(Smoke::Index classId, void *object); + + virtual bool + callMethod(Smoke::Index method, void* object, + Smoke::Stack stack, bool abstract); + + virtual char* + className(Smoke::Index classId); + + private: + const destructed destruct; +}; + +class Binding : public NoDispatchBinding +{ + public: + typedef int (*dispatch_method)(Smoke::Index method, + void* object, Smoke::Stack args, int abstract); + + Binding(destructed destruct, dispatch_method dispatch); + + + virtual bool + callMethod(Smoke::Index method, void* object, + Smoke::Stack stack, bool abstract); + + + private: + const dispatch_method dispatch; +}; + +} // namespace cl_smoke + +#endif // SMOKEBINDING_H diff -rN -u old-smoke/src/libsmoke/stack.lisp new-smoke/src/libsmoke/stack.lisp --- old-smoke/src/libsmoke/stack.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/libsmoke/stack.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,21 @@ +(in-package #:smoke) + +(defcunion smoke-stack-item + "A variable on the Smoke stack" + (voidp :pointer) + (bool cxx-bool) + (char :char) + (uchar :unsigned-char) + (short :short) + (ushort :unsigned-short) + (int :int) + (uint :unsigned-int) + (long :long) + (ulong :unsigned-long) + (float :float) + (double :double) + (enum-value :long) + (class :pointer)) + +(defctype smoke-stack (:pointer smoke-stack-item) + "A Smoke call stack.") diff -rN -u old-smoke/src/libsmoke/type.lisp new-smoke/src/libsmoke/type.lisp --- old-smoke/src/libsmoke/type.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/libsmoke/type.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,20 @@ +(in-package #:smoke) + +(defcenum smoke-type-flags + "Type properties" + (:type-id #x0F) + + (:stack #x10) + (:pointer #x20) + (:reference #x30) + + (:const #x40)) + +(defcstruct smoke-type + (name :string) + (class smoke-index) + (flags :unsigned-short)) + +(defcfun (smoke-find-type "cl_smoke_find_type") smoke-index + (smoke :pointer) + (name :string)) diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp --- old-smoke/src/object-map.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/object-map.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,120 @@ +(in-package :smoke) + +#+sbcl +(defun make-synchronized-hash-table (&key weakness) + (if weakness + (make-weak-hash-table :weakness weakness :synchronized t) + (make-weak-hash-table :synchronized t))) + +#+openmcl +(let ((ccl::*shared-hash-table-default* t)) + (defun make-synchronized-hash-table (&key weakness) + (if weakness + (make-weak-hash-table :weakness weakness) + (make-weak-hash-table)))) + +#-(or sbcl openmcl) +(progn + (when *supports-threads-p* + (cerror "Use unsynchronized hash-table" + "Synchronized hash table not implemented.")) + (defun make-synchronized-hash-table (&key weakness) + (if weakness + #-cmucl (make-weak-hash-table :weakness weakness) + #+cmucl (make-hash-table :weak-p weakness) + (make-hash-table)))) + +;; FIXME +;; CLISP has problems with weak hash tables and finalizers. +;; trivial-garbage has a workaround!? +;; http://sourceforge.net/tracker/index.php?func=detail&aid=1472478&group_id=1355&atid=101355 +;; crashes 2.47 and 2.44.1 +;; Works when not using a weak hash table, but now we are leaking memory! + + +(defvar *object-map* (make-synchronized-hash-table :weakness :value) + "Contains all objects constructed by Smoke, that are not yet destructed; +except object with a non virtual destructor which had their ownership +transferred to C++.") + +(eval-on-save () + (tg:gc :full t) ;; Try to get all #'smoke::make-auto-pointer + (loop for object being the hash-value of *object-map* do + (warn "life object ~A ~A" object (pointer object)) + (remove-finalizer object) + (setf (slot-value object 'pointer) (null-pointer))) + (clrhash *object-map*)) + +(declaim (inline get-object)) +(defun get-object (pointer) + (gethash (pointer-address pointer) *object-map*)) + +(declaim (inline (setf get-object))) +(defun (setf get-object) (value pointer) + (setf (gethash (pointer-address pointer) *object-map*) + value)) + +(declaim (inline has-pointer-p)) +(defun has-pointer-p (pointer) + "Returns T when there is an object for POINTER in the map and NIL otherwise." + (nth-value 1 (gethash (pointer-address pointer) *object-map*))) + +(defun remove-object (pointer) + (unless (remhash (pointer-address pointer) *object-map*) + (cerror "ignore" "No object to remove for pointer ~A." pointer))) + +(defun report-finalize-error (condition function class pointer) + "Report the error CONDITION it the finalizer FUNCTION for the +object at POINTER of class CLASS." + (warn "error calling finalizer ~A for ~A ~A:~%~5T~A~%" + function class pointer condition) + #+sbcl (sb-debug:backtrace 10)) + +(declaim (inline remove-finalizer)) +(defun remove-finalizer (object) + #-clisp + (cancel-finalization object) + #+clisp + (when (typep object 'smoke-standard-object) + (cancel-finalization (slot-value object 'finalizer)))) + +(declaim (inline set-finalizer)) +(defun set-finalizer (object) + #-clisp + (finalize object (make-finalize object)) + #+clisp + (finalize (slot-value object 'finalizer) (make-finalize object))) + +(defgeneric make-finalize (object) + (:documentation "Returns a function to be called when OBJECT is finalized.")) + +(defmethod make-finalize (object) + (let ((pointer (pointer object)) + (class (class-of object))) + #'(lambda () + (declare (optimize (speed 3))) + ;; #'remove-object is called in the destructed callback. This + ;; happens even for objects without an virtual destructor. + (handler-case (delete-pointer pointer class) + (error (condition) + (report-finalize-error condition 't (name class) pointer)))))) + +(defun debug-finalize () + (eval '(defmethod make-finalize :around (object) + (let ((pointer (pointer object)) + (class (class-of object)) + (next (call-next-method))) + #'(lambda () + (format *debug-io* "cl-smoke: finalizing: ~A..." + (make-instance class :pointer pointer)) + (funcall next) + (format *debug-io* "done~%")))))) + +(defun add-object (object) + "Adds OBJECT to the pointer -> object map. It can later be retrieved +with GET-OBJECT." + (when (has-pointer-p (pointer object)) + (cerror "Overwrite the old object." + "There exists already a object ~A for the pointer of ~A." + (get-object (pointer object)) object)) + (setf (get-object (pointer object)) object)) diff -rN -u old-smoke/src/objects/class.lisp new-smoke/src/objects/class.lisp --- old-smoke/src/objects/class.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/objects/class.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,153 @@ +(in-package #:smoke) + +(defclass smoke-class () + ((id :initform 0 :type smoke-index + :reader id :initarg :id) + (smoke :type smoke-module + :reader smoke :initarg :smoke))) + +(defun make-smoke-class-from-id (smoke id) + (make-instance 'smoke-class :id id :smoke smoke)) + +(declaim (inline smoke-class-pointer)) +(defun smoke-class-pointer (class) + (mem-aref (the foreign-pointer + (smoke-array-pointer (smoke-module-classes (smoke class)))) + 'smoke-class + (the smoke-index (id class)))) + +(declaim (inline class-slot-value)) +(defun class-slot-value (class slot-name) + (foreign-slot-value (smoke-class-pointer class) + 'smoke-class slot-name)) + +(define-compiler-macro class-slot-value (&whole form class slot-name) + (if (constantp slot-name) + `(foreign-slot-value (smoke-class-pointer ,class) + 'smoke-class ,slot-name) + form)) + +(defmethod name ((class smoke-class)) + (class-slot-value class 'name)) + +(defun name-pointer (class) + (mem-ref (foreign-slot-pointer (smoke-class-pointer class) + 'smoke-class 'name) + :pointer)) + +(defun class-size (smoke-class) + (class-slot-value smoke-class 'size)) + +(defun map-classes (function smoke) + "Applies FUNCTION to the classes of SMOKE." + (declare (function function) + (optimize (speed 3))) + (let ((class (make-instance 'smoke-class + :smoke smoke))) + (loop for id from 1 to (smoke-array-length (smoke-module-classes smoke)) do + (setf (slot-value class 'id) + id) + (funcall function class)))) + +(defun external-p (class) + "Returns T when CLASS is external in its module; NIL otherwise." + (declare (type smoke-class class) + (optimize (speed 3))) + (class-slot-value class 'external)) + +(defun get-class-flag (class flag) + (declare (optimize (speed 3))) + (logand (class-slot-value class 'flags) + (the fixnum (foreign-enum-value 'smoke-class-flags flag)))) + +(defmethod constructor-p ((class smoke-class)) + "Returns T when CLASS has a constructor; NIL otherwise." + (/= 0 (get-class-flag class :constructor))) + +(defun copy-constructor-p (class) + (/= 0 (get-class-flag class :copy-constructor))) + +(defun virtual-destructor-p (class) + "Returns T when CLASS has a virtual destructor and NIL otherwise." + (/= 0 (get-class-flag class :virtual-destructor))) + +(define-condition undefined-class (cell-error) + () + (:report (lambda (condition stream) + (format stream "No Smoke class named ~S." + (cell-error-name condition)))) + (:documentation "A undefined Smoke class")) + +(define-condition lisp-module-not-loaded (error) + ((class-name :initarg :class-name)) + (:report (lambda (condition stream) + (format stream "The Lisp smoke module of the class ~A is not loaded." + (slot-value condition 'class-name))))) + +(defun make-smoke-class (name) + "Returns the class named NAME. +Signals an undefined-class condition when there is no class for NAME." + (with-foreign-object (c 'smoke-module-index) + (do () (nil) + (smoke-find-class c name) + (restart-case + (if (null-pointer-p (foreign-slot-value c 'smoke-module-index 'smoke)) + (error (make-condition 'undefined-class :name name)) + (return)) + (supply (new-name) + :report "Supply a new class name" + :interactive read-new-value + (setf name new-name)))) + (let ((class (make-instance + 'smoke-class + :id (foreign-slot-value c 'smoke-module-index 'index) + :smoke (gethash (pointer-address (foreign-slot-value + c 'smoke-module-index + 'smoke)) + *smoke-modules*)))) + (unless (smoke class) + (error (make-condition 'lisp-module-not-loaded :class-name name))) + class))) + +(defun real-class (class) + "Returns the same class like CLASS, but such that EXTERNAL-P returns NIL." + (if (external-p class) + (make-smoke-class (name class)) + class)) + +(defun class-id (module class) + "Returns the class id of CLASS for the Smoke module MODULE." + (if (eq (smoke class) module) + (id class) + (smoke-class-id module (name class)))) + +(defun derived-p (class base-class) + "Returns T when CLASS is derived from BASE-CLASS and NIL when not." + (handler-case (derived-real-p (real-class class) (real-class base-class)) + ;; The class is external in every module => no derived. + (undefined-class () nil))) + +(defun derived-real-p (class base-class) + (smoke-is-derived-from (smoke-module-pointer (smoke class)) + (id class) + (smoke-module-pointer (smoke base-class)) + (id base-class))) + + +(defun smoke-class-direct-superclasses (class) + (smoke-add-superclass class nil (class-slot-value class 'parents))) + +(defun smoke-add-superclass (class classes index) + (let ((class-index (mem-aref (smoke-module-inheritance-list + (smoke class)) + 'smoke-index + index))) + (assert (<= class-index (smoke-array-length + (smoke-module-classes (smoke class))))) + (if (= 0 class-index) + classes + (smoke-add-superclass + class + (append classes + (list (make-smoke-class-from-id (smoke class) class-index))) + (1+ index))))) diff -rN -u old-smoke/src/objects/enum.lisp new-smoke/src/objects/enum.lisp --- old-smoke/src/objects/enum.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/objects/enum.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,85 @@ +(in-package :cxx-support) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :smoke :cxx-support)) + +;;; One could map enum-values to lisp symbols, store the type in the plist +;;; an use those as enums, but C++ enums may have several symbols for +;;; the same value and thus lisp symbols can not be used. + +(defclass enum () + ((value :reader value + :type integer + :initarg :value) + (type :reader enum-type + :initarg :type)) + (:documentation "Holds the integer value and type of an C++ enum value.")) + +;; Clozure CL needs this +;; for the constants (e.g.: QT:+ALT+) +(defmethod make-load-form ((enum enum) &optional environment) + `(make-instance 'enum + :value ,(value enum) + :type ,(make-load-form (enum-type enum) environment))) + +(defmethod print-object ((enum enum) stream) + (print-unreadable-object (enum stream :type t) + (format stream "~A ~A" (name (enum-type enum)) + (value enum)))) + + +(defun check-enum-type (enum enum-type) + (assert (smoke-type= (enum-type enum) + enum-type) + (enum enum-type) + "The enums ~A is not of type ~A." enum (name enum-type))) + +(defun enum= (enum1 enum2) + "Returns true when ENUM1 and ENUM2 are equal and false otherwise." + (declare (enum enum1 enum2)) + (assert (smoke-type= (enum-type enum1) + (enum-type enum2)) + (enum1 enum2) + "The enums ~A and ~A have a different type." enum1 enum2) + (= (value enum1) (value enum2))) + +(defmacro enum-xcase (case keyform &body cases) + (flet ((first-key (keys) + (if (listp keys) + (first keys) + keys))) + (let ((type (enum-type (eval (first-key (first (first cases))))))) + (loop for case in cases do + (check-enum-type (eval (first-key (first case))) + type))) + `(progn + ;; (check-enum-type (enum-type ,keyform) + ;; (enum-type ,(first (first cases)))) + (,case (value ,keyform) + ,@(loop for case in cases + collect `(,(if (listp (first case)) + (mapcar #'(lambda (c) + (print c) + (value (eval c))) + (first case)) + (value (eval (first case)))) + ,@(rest case))))))) + +(defmacro enum-case (keyform &body cases) + `(enum-xcase case ,keyform ,@cases)) + +(defmacro enum-ecase (keyform &body cases) + `(enum-xcase ecase ,keyform ,@cases)) + +(defmacro enum-cases (keyform &body cases) + "Keyform returns a number; cases are enums." + `(case ,keyform + ,@(loop for case in cases + collect `(,(value (eval (first case))) + ,@(rest case))))) + +(defun enum-logand (&rest enums) + (apply #'logand (mapcar #'value enums))) + +(defun enum-logior (&rest enums) + (apply #'logior (mapcar #'value enums))) diff -rN -u old-smoke/src/objects/instance.lisp new-smoke/src/objects/instance.lisp --- old-smoke/src/objects/instance.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/objects/instance.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,7 @@ +(in-package #:smoke) + +(defclass object (smoke-class) + ((pointer :reader pointer :initarg :pointer + :initform (null-pointer) + :documentation "Pointer to the C++ object.")) + (:documentation "A Smoke CPP object")) diff -rN -u old-smoke/src/objects/method.lisp new-smoke/src/objects/method.lisp --- old-smoke/src/objects/method.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/objects/method.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,277 @@ +(in-package #:smoke) + +(declaim (inline make-smoke-method)) +(defstruct smoke-method + (id 0 :type smoke-index) + (smoke (make-smoke-module) :type smoke-module)) + +(declaim (inline smoke-method-pointer)) +(defun smoke-method-pointer (method) + (declare (optimize (speed 3))) + (mem-aref (smoke-array-pointer (smoke-module-methods + (smoke-method-smoke method))) + 'smoke-method + (smoke-method-id method))) + +(defmethod print-object ((smoke-method smoke-method) stream) + (if (or (null-pointer-p (smoke-module-pointer + (smoke-method-smoke smoke-method))) + (null-pointer-p (smoke-method-pointer smoke-method))) + (print-unreadable-object (smoke-method stream :type t) + (princ "no method" stream)) + (print-unreadable-object (smoke-method stream :type t) + (princ (method-declaration smoke-method) stream)))) + +(defmethod smoke ((method smoke-method)) + (smoke-module-pointer (smoke-method-smoke method))) + +(defmethod id ((method smoke-method)) + (declare (optimize (speed 3))) + (smoke-method-id method)) + +(define-condition undefined-method (undefined-function) + ((class-name :initarg :class-name + :initform nil)) + (:report (lambda (condition stream) + (format stream "No Smoke method ~S for class ~S." + (cell-error-name condition) + (slot-value condition 'class-name)))) + (:documentation "A undefined Smoke method")) + +(defun find-smoke-method (class name) + "Returns the method NAME of CLASS." + (with-foreign-object (m 'smoke-module-index) + (smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name) + (let ((smoke (foreign-slot-value m 'smoke-module-index 'smoke))) + (make-smoke-method + :smoke (if (null-pointer-p smoke) + (make-smoke-module) + (gethash (pointer-address smoke) *smoke-modules*)) + :id (foreign-slot-value m 'smoke-module-index 'index))))) + +(declaim (inline smoke-method-name)) +(defun smoke-method-name (method) + (mem-aref (smoke-array-pointer (smoke-module-method-names + (smoke-method-smoke method))) + :pointer + (the (smoke-index 0) (method-slot-value method 'name)))) + +;smoke-find-method +(defun make-smoke-method-from-name (class name) + "Returns the method NAME of CLASS. +Signals a undefined-method condition when no method was found. +Signals an error when the method is ambiguous." + (with-foreign-object (m 'smoke-module-index) + (do () (nil) + (smoke-find-method m (smoke-module-pointer (smoke class)) (id class) name) + (restart-case + (if (null-pointer-p (foreign-slot-value m 'smoke-module-index 'smoke)) + (error (make-condition 'undefined-method :name name :class-name (name class))) + (return)) + (supply (new-name) + :report "Supply a new method name" + :interactive read-new-value + (setf name new-name)))) + (when (> 0 (foreign-slot-value m 'smoke-module-index 'index)) + (loop as i = (mem-aref (smoke-module-ambiguous-method-list (smoke class)) + 'smoke-index + (- (foreign-slot-value m 'smoke-module-index 'index))) + while (> i 0) + do (decf (foreign-slot-value m 'smoke-module-index 'index)) + (let ((m (make-smoke-method :smoke (smoke class) :id i))) + (format t " ~A ~A~%" (name m) (signature m)))) + (error "The method ~S of ~S is ambiguous" name (name class))) ;;TODO + (make-smoke-method + :smoke (gethash (pointer-address + (foreign-slot-value m 'smoke-module-index 'smoke)) + *smoke-modules*) + :id (foreign-slot-value m 'smoke-module-index 'index)))) + +(defun map-methods (function smoke) + "Applies FUNCTION to the methods of SMOKE. +The method argument to function must not be modified." + (declare (function function) + (optimize (speed 3))) + (let ((method (make-smoke-method :smoke smoke :id 0)) + (length (smoke-array-length (smoke-module-methods smoke)))) + (loop for id from 0 below length do ;; exception: methods is < lenght + (setf (smoke-method-id method) id) + (funcall function method)))) + +(declaim (inline method-slot-value)) +(defun method-slot-value (method slot-name) + (declare (smoke-method method) + (symbol slot-name) + (optimize (speed 3))) + (foreign-slot-value (smoke-method-pointer method) + 'smoke-method slot-name)) + +(define-compiler-macro method-slot-value (&whole form method slot-name) + "Optimize constant slot-names." + ;; declaring the function inline calls the compiler macro of + ;; foreign-slot-value with 'SLOT-NAME instead of its value an thus + ;; has no effect; thus the compiler macro. + (if (constantp slot-name) + `(foreign-slot-value (smoke-method-pointer ,method) + 'smoke-method ,slot-name) + form)) + + +(defmethod name ((method smoke-method)) + (mem-aref (smoke-array-pointer (smoke-module-method-names + (smoke-method-smoke method))) + :string + (method-slot-value method 'name))) + +(defun signature (method) + "Returns the signature of METHOD." + (format nil "~A(~{~A~^, ~}) ~:[~;const~]" + (name method) + (mapcar #'name (arguments method)) + (const-p method))) + +(defun access (method) + "Returns the access for METHOD. (public or protected)" + (if (protected-p method) + "protected" + "public")) + +(defun modifiers (method) + (format nil "~:[~;virtual ~]~A~:[~; static~]" + (virtual-p method) (access method) (static-p method))) + +(defun return-type (method) + "Returns the return type of METHOD." + (declare (optimize (speed 3))) + (make-instance 'smoke-type + :id (method-slot-value method 'return-type) + :smoke (smoke-method-smoke method))) + +(defun method-declaration (method) + (format nil "~A~:[ void~; ~1:*~A~] ~A::~A" + (modifiers method) + (name (return-type method)) + (name (get-class method)) + (signature method))) + +(defun get-method-flag (method flag) + (logand (method-slot-value method 'flags) + (foreign-enum-value 'smoke-method-flags flag))) + +(define-compiler-macro get-method-flag (&whole form method flag) + (if (constantp flag) + `(logand (method-slot-value ,method 'flags) + ;; Resolve flag value at compile time + ,(foreign-enum-value 'smoke-method-flags flag)) + form)) + +(defgeneric constructor-p (object) + (:documentation "Returns T when OBJECT is a constructor.")) + +(defmethod constructor-p ((method smoke-method)) + (/= 0 (get-method-flag method :constructor))) + +(defun destructor-p (method) + "Returns T when METHOD is a destructor; NIL otherwise." + (/= 0 (get-method-flag method :destructor))) + +(defun static-p (method) + "Returns T when METHOD is static and NIL otherwise." + (/= 0 (get-method-flag method :static))) + +(defun protected-p (method) + "Returns T when METHOD is protected; NIL otherwise." + (/= 0 (get-method-flag method :protected))) + +(defun attribute-p (method) + "Returns T when METHOD accesses C++ member/static variables." + (/= 0 (get-method-flag method :attribute))) + +(defun property-p (method) + "Returns T when METHOD accesses a Q_PROPERTY." + (/= 0 (get-method-flag method :property))) + +(defmethod const-p ((method smoke-method)) + "Returns T when METHOD is a const method and NIL otherwise." + (/= 0 (get-method-flag method :const))) + +(defun valid-p (method) + "Returns T when METHOD is valid and NIL otherwise." + (/= 0 (smoke-method-id method))) + +(defun ambigious-p (method) + "Returns T when METHOD is ambiguous and NIL otherwise." + (< 0 (smoke-method-id method))) + +(defun enum-p (method) + "Returns T when METHOD is enum value and NIL otherwise." + (/= 0 (get-method-flag method :enum))) + +(defun internal-p (method) + "Returns T when METHOD is internal and NIL otherwise." + (/= 0 (get-method-flag method :internal))) + +(defun virtual-p (method) + "Returns T when METHOD is internal and NIL otherwise." + (/= 0 (get-method-flag method :virtual))) + +(defmethod get-class ((method smoke-method)) + (make-smoke-class-from-id + (smoke-method-smoke method) + (method-slot-value method 'class))) + +(defclass smoke-argument (smoke-type) + () + (:documentation "A argument to a method")) + +(defmethod id ((argument smoke-argument)) + (declare (optimize (speed 3))) + (mem-aref (smoke-module-argument-list (smoke argument)) + 'smoke-index + (the smoke-index (call-next-method)))) + +(defun last-p (argument) + "Returns T when ARGUMENT is the last argument and NIL otherwise." + (= 0 (mem-aref (smoke-module-argument-list (smoke argument)) + 'smoke-index + (1+ (slot-value argument 'id))))) + +(defun end-p (argument) + "Returns T when ARGUMENT is the after last element and NIL otherwise." + (= 0 (id argument))) + +(defun next (argument) + "Returns the argument following ARGUMENT." + (assert (not (end-p argument)) + (argument) + "Access after end element") + (make-instance 'smoke-argument + :id (1+ (slot-value argument 'id)) + :smoke (smoke argument))) + +(defun get-arguments-length (method) + "Returns the number of arguments for METHOD." + (method-slot-value method 'num-args)) + +(defun get-first-argument (method) + "Returns the first argument of METHOD" + (declare (optimize (speed 3))) + (make-instance 'smoke-argument + :id (method-slot-value method 'arguments) + :smoke (smoke-method-smoke method))) + +(defun get-argument (method index) + "Returns the type of METHODs argument with number INDEX." + (make-instance 'smoke-argument + :id (+ (method-slot-value method 'arguments) index) + :smoke (smoke-method-smoke method))) + +(defun build-argument-list (list argument) + (if (end-p argument) + list + (build-argument-list (append list (list argument)) + (next argument)))) + +(defun arguments (method) + "Returns a list of the arguments of METHOD." + (build-argument-list nil (get-first-argument method))) diff -rN -u old-smoke/src/objects/object.lisp new-smoke/src/objects/object.lisp --- old-smoke/src/objects/object.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/objects/object.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,3 @@ +(in-package #:smoke) + +(declaim (inline id)) diff -rN -u old-smoke/src/objects/stack.lisp new-smoke/src/objects/stack.lisp --- old-smoke/src/objects/stack.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/objects/stack.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,194 @@ +(in-package #:smoke) + +(declaim (inline %make-call-stack)) +(defstruct (call-stack (:constructor %make-call-stack)) + (pointer (null-pointer) :type foreign-pointer) + (top (null-pointer) :type foreign-pointer)) + +(defgeneric size (object)) +(defmethod size ((stack call-stack)) + "Returns the size (number of arguments) of STACK." + (/ (- (pointer-address (call-stack-top stack)) + (pointer-address (call-stack-pointer stack))) + (foreign-type-size 'smoke-stack-item))) + +(defun make-call-stack (smoke-stack) + (declare (type foreign-pointer smoke-stack) + (optimize (speed 3))) + (%make-call-stack + :pointer smoke-stack + :top (inc-pointer smoke-stack #.(foreign-type-size 'smoke-stack-item)))) + +(defun push-stack (stack value type) + (setf (foreign-slot-value (call-stack-top stack) 'smoke-stack-item type) + value) + (incf-pointer (call-stack-top stack) #.(foreign-type-size 'smoke-stack-item))) + +(define-compiler-macro push-stack (&whole form stack value type) + (if (constantp type) + `(progn + (setf (foreign-slot-value (call-stack-top ,stack) + 'smoke-stack-item ,type) + ,value) + (incf-pointer (call-stack-top ,stack) + ,(foreign-type-size 'smoke-stack-item))) + form)) + +(defclass smoke-standard-object () + ((pointer :reader pointer + :type foreign-pointer + :initarg :pointer + :documentation "Pointer to the C++ object.") + (const-p :reader const-p + :initarg :const-p + :initform nil + :documentation "Returns true when the object is const and nil otherwise.") + #+clisp (finalizer :type list :initform (list nil)) + ;; We can not have a global table of objects owned by C++, + ;; since then they would be always reachable from Lisp and thus + ;; cycles would never be garbage collected. + (owned-objects :accessor owned-objects + :initform nil + :type list + :documentation "Objects owned by the C++ instance.")) + (:documentation "The standard superclass for Smoke classes.")) + +(defun push-smoke-stack (stack value type-id) + (declare (type (smoke-index 0) type-id) + (type call-stack stack) + (optimize (speed 3))) + (ecase type-id + (0 (push-stack stack value 'voidp)) + (1 (push-stack stack value 'bool)) + (2 (push-stack stack (char-code value) 'char)) + (3 (push-stack stack value 'uchar)) + (4 (push-stack stack value 'short)) + (5 (push-stack stack value 'ushort)) + (6 (push-stack stack value 'int)) + (7 (push-stack stack value 'uint)) + (8 (push-stack stack value 'long)) + (9 (push-stack stack value 'ulong)) + (10 (push-stack stack value 'float)) + (11 (push-stack stack value 'double)) + (12 (push-stack stack (value value) 'enum-value)) + (13 (if (typep value 'smoke-standard-object) + ;; FIXME call pointer in overload resolution + (push-stack stack (pointer value) 'class) + (push-stack stack value 'class))))) + +(defun set-smoke-stack (stack args arguments) + "Pushes the arguments ARGS onto the Smoke stack STACK." + (when (null args) + (assert (null arguments) + () + "To few arguments supplied. Missing: ~A" arguments)) + (unless (null args) + (assert (not (null arguments)) + () + "To many arguments supplied (Arguments ~A)." args) + (if (typep (first arguments) 'smoke-type) + (push-smoke-stack stack (first args) (type-id (first arguments))) + (push-stack stack (first args) 'class)) ;; Used for :qt lisp-object + (set-smoke-stack stack (rest args) (rest arguments)))) + +(defmacro with-stack ((stack args types) &body body) + (let ((smoke-stack (gensym "STACK"))) + `(with-foreign-object (,smoke-stack 'smoke-stack-item (1+ (length ,args))) + (let ((,stack (make-call-stack ,smoke-stack))) + (set-smoke-stack ,stack ,args + ,types) + ,@body)))) + +(defvar *to-lisp-translations* (make-hash-table :test 'equal)) + +(defun enum-to-lisp (stack-item type) + "Returns the Lisp representation for STACK-ITEM of the basic C type TYPE." + (declare (optimize (speed 3))) + (ecase (type-id type) + (0 (if-let ((translation (gethash (name type) *to-lisp-translations*))) + (let ((pointer (foreign-slot-value stack-item 'smoke-stack-item + 'voidp))) + (prog1 (funcall (car translation) pointer) + (when (stack-p type) + (funcall (cdr translation) pointer)))) + (prog1 (foreign-slot-value stack-item 'smoke-stack-item 'voidp) + (cerror "Return the pointer" + "Missing type translator to convert the type ~A to Lisp." + type)))) + (1 (foreign-slot-value stack-item 'smoke-stack-item 'bool)) + (2 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'char))) + (3 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'uchar))) + (4 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'short))) + (5 (code-char (foreign-slot-value stack-item 'smoke-stack-item 'ushort))) + (6 (foreign-slot-value stack-item 'smoke-stack-item 'int)) + (7 (foreign-slot-value stack-item 'smoke-stack-item 'uint)) + (8 (foreign-slot-value stack-item 'smoke-stack-item 'long)) + (9 (foreign-slot-value stack-item 'smoke-stack-item 'ulong)) + (10 (foreign-slot-value stack-item 'smoke-stack-item 'float)) + (11 (foreign-slot-value stack-item 'smoke-stack-item 'double)) + (12 (make-instance 'enum + :value (foreign-slot-value stack-item 'smoke-stack-item + 'enum-value) + :type type)))) + +(defgeneric instance-to-lisp (pointer class type) + (declare (optimize (speed 3))) + (:documentation "Returns a CLOS instance for POINTER.")) + +(defun object-to-lisp (object type) + (declare (optimize (speed 3))) + (let ((class (get-class type))) + (if (has-pointer-p object) + (if (derived-p (class-of (get-object object)) + (get-class type)) + (get-object object) + (progn + (when (stack-p type) + ;; The first member varible of a class can have the + ;; same address as its object. + ;; e.g.: QSharedData::ref + (cerror "Remove the old object." + "The object at pointer ~A is ~A but should be a ~A." + object (get-object object) type) + (remove-object object)) + (instance-to-lisp object (find-smoke-class class) type))) + (instance-to-lisp object (find-smoke-class class) type)))) + + + +(defun class-to-lisp (stack-item type) + "Returns the Lisp representation for STACK-ITEM of type C++ class." + (object-to-lisp (foreign-slot-value stack-item 'smoke-stack-item + 'class) + type)) + +(defun type-to-lisp (stack-item type) + "Returns the Lisp representation of STACK-ITEM" + (declare (optimize (speed 3))) + (cond + ((void-p type) (values)) + ((class-p type) (class-to-lisp stack-item type)) + (t (enum-to-lisp stack-item type)))) + + +(defun error-no-free (object) + (error "Can not free object at ~A." object)) + +(defmacro define-to-lisp-translation (type-names &optional + (conversion-function-name 'identity) + (free-function-name 'error-no-free)) + `(progn ,@(loop for type-name in (ensure-list type-names) + collect `(setf (gethash ,type-name *to-lisp-translations*) + (cons ',conversion-function-name + ',free-function-name))))) + +(defmacro define-pointer-typedef (type-names lisp-type) + (declare (ignore lisp-type)) + `(progn + (define-to-lisp-translation ,type-names identity identity))) + ;; not needed + ;;(define-from-lisp-translation ,type-names ,lisp-type))) + +(define-to-lisp-translation ("void*" "const void*" "void**")) + +(define-to-lisp-translation ("char*" "const char*") foreign-string-to-lisp) diff -rN -u old-smoke/src/objects/type.lisp new-smoke/src/objects/type.lisp --- old-smoke/src/objects/type.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/objects/type.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,151 @@ +(in-package #:smoke) + +(declaim (inline smoke)) + +(defclass smoke-type () + ((id :reader id :initarg :id + :type smoke-index + :documentation "The objects index.") + (smoke :reader smoke :initarg :smoke + :type smoke-module + :documentation "Pointer to the Smoke module.")) + (:documentation "A type")) + +(defmethod print-object ((type smoke-type) stream) + (if (or (<= (id type) 0) + (null-pointer-p (smoke-module-pointer (smoke type)))) + (call-next-method) + (print-unreadable-object (type stream :type t) + (princ (name type) stream)))) + +;; Clozure CL needs this +(defmethod make-load-form ((type smoke-type) &optional environment) + (declare (ignore environment)) + `(make-instance 'smoke-type + :id ,(id type) + :smoke (eval ,(get-smoke-variable-for-pointer + (smoke-module-pointer (smoke type)))))) + +(declaim (inline type-slot-value)) +(defun type-slot-value (type slot-name) + (declare (smoke-type type) + (symbol slot-name) + (optimize (speed 3))) + (foreign-slot-value (mem-aref (smoke-array-pointer + (smoke-module-types (smoke type))) + 'smoke-type + (the smoke-index (id type))) + 'smoke-type slot-name)) + +(define-compiler-macro type-slot-value (&whole form type slot-name) + (if (constantp slot-name) + `(foreign-slot-value (mem-aref (smoke-array-pointer + (smoke-module-types (smoke ,type))) + 'smoke-type + (the smoke-index (id ,type))) + 'smoke-type ,slot-name) + form)) + + +(defun make-smoke-type (smoke name) + "Returns the type in the Smoke module SMOKE named NAME." + (make-instance 'smoke-type + :id (smoke-find-type (smoke-module-pointer smoke) name) + :smoke smoke)) + +(defmethod name ((type smoke-type)) + (declare (optimize (speed 3))) + (type-slot-value type 'name)) + +(defun smoke-type= (type1 type2) + (if (eq (smoke type1) (smoke type2)) + (= (id type1) (id type2)) + (string= (name type1) (name type2)))) + +(defun get-type-flag (type flag) + (declare (optimize (speed 3))) + (logand (type-slot-value type 'flags) + #xF0 ;; = !0x0F + (the fixnum (foreign-enum-value 'smoke-type-flags flag)))) + +(define-compiler-macro get-type-flag (&whole form type flag) + (if (constantp flag) + `(logand (type-slot-value ,type 'flags) + #xF0 + ,(foreign-enum-value 'smoke-type-flags flag)) + form)) + +(defmacro allocation-flag-p (type flag) + ;; Can't just use #'get-type-flag since it can only be one of + ;; :stack, :reference and :pointer. + ;; (:stack + :pointer = :reference) <=> (#x10 + #x20 = #x30) + `(= ,(foreign-enum-value 'smoke-type-flags flag) + (logand #x30 + (type-slot-value ,type 'flags)))) + +(declaim (inline stack-p)) +(defun stack-p (type) + "Returns T when TYPE is stored on the stack; NIL otherwise." + (allocation-flag-p type :stack)) + +(defun reference-p (type) + "Returns T when TYPE is a reference ('type&'); NIL otherwise." + (allocation-flag-p type :reference)) + +(defun pointer-p (type) + "Returns T when TYPE is a pointer ('type*'); NIL otherwise." + (allocation-flag-p type :pointer)) + +(defgeneric const-p (object) + (:method ((type smoke-type)) + "Returns T when TYPE is const; NIL otherwise." + (/= 0 (get-type-flag type :const)))) + +(defun class-p (type) + "Returns T when TYPE is a smoke class" + (and (eql (type-id type) 13) + (not (zerop (type-slot-value type 'class))))) + +(defun type-id (type) + "Returns the ID of TYPE." + (declare (smoke-type type) + (optimize (speed 3) (safety 0))) + (logand (the (c-integer :unsigned-short) (type-slot-value type 'flags)) + #.(foreign-enum-value 'smoke-type-flags :type-id))) + +(defun void-p (type) + "Return T when TYPE is a void type (no value)." + ;; void is an empty string. + ;; For efficiency just check if the first byte is a null byte; + ;; No need to convert the entire C string to lisp like in: + ;; (null (name type))) + (declare (optimize (speed 3))) + (null-pointer-p (mem-ref + (foreign-slot-pointer + (mem-aref (smoke-array-pointer + (smoke-module-types (smoke type))) + 'smoke-type + (the smoke-index (id type))) + 'smoke-type 'name) + :pointer))) + + +(defgeneric get-class (smoke-symbol) + (:documentation "Returns the smoke-class associated with SMOKE-SYMBOL.")) + +(defmethod get-class ((type smoke-type)) + "Return the smoke-class of TYPE." + (assert (class-p type) + (type) + "The type ~S is not a smoke class." type) + (make-smoke-class-from-id (smoke type) (type-slot-value type 'class))) + +;; Return the cffi keyword for the type +(defun type-foreign-keyword (smoke-type) + (intern (nsubstitute #\- #\ (nstring-upcase (name smoke-type))) + :keyword)) + +(defun type-size (smoke-type) + (if (class-p smoke-type) + (class-size (get-class smoke-type)) + (foreign-type-size (type-foreign-keyword smoke-type)))) diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp --- old-smoke/src/overload-resolution.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/overload-resolution.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,605 @@ +;;; C++ overload resolution +;;; See: http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2008/n2800.pdf +;;; +;;; We handle only the most common cases. Stuff like virtual inheritance +;;; that is not needed is not implemented. + +(in-package :smoke) + +(declaim (inline cmp)) +(defun cmp (a b) + (- a b)) + +(declaim (inline strcmp)) +(defcfun strcmp :int (s1 :pointer) (s2 :pointer)) + +(declaim (inline cstring/=)) +(defun cstring/= (string1 string2) + "Returns T when the C strings STRING1 and STRING2 are not equal + and NIL otherwise." + (not (zerop (strcmp string1 string2)))) + +(defun method-cmp (method class-id name) + "Compares METHOD to the method with NAME of class CLASS-ID." + (declare (foreign-pointer name) + (type (smoke-index 0) class-id) + (smoke-method method) + (optimize (speed 3) (debug 0) (safety 0))) + (let ((id-cmp (cmp (the (smoke-index 0) (method-slot-value method 'class)) + (the (smoke-index 0) class-id)))) + (declare (type smoke-index id-cmp)) + (if (/= 0 id-cmp) + id-cmp + (strcmp (smoke-method-name method) + name)))) + +(declaim (inline first-unabigious-index)) +(defun first-unabigious-index (smoke index) + (declare (type smoke-index index) + (optimize (speed 3))) + (if (>= index 0) + index + (mem-aref (smoke-module-ambiguous-method-list smoke) + 'smoke-index + (- index)))) + +(defun find-method-for-class (name class) + "Returns the index of a method with name NAME for class CLASS." + (declare (type foreign-pointer name) + (type smoke-class class) + (optimize (speed 3))) + (let* ((start 1) ;; 0 is "no method" + (class-id (id class)) + (smoke (smoke class)) + (end (1+ (smoke-array-length (smoke-module-method-maps smoke))))) + (declare (type (smoke-index 0) start end) + (dynamic-extent start)) + (loop until (> start end) do + (let* ((index (the smoke-index (floor (+ end start) 2))) + (method (make-smoke-method + :smoke smoke + :id (the (smoke-index 0) + (first-unabigious-index + smoke + (foreign-slot-value + (mem-aref (smoke-array-pointer + (smoke-module-method-maps + smoke)) + 'smoke-method-map index) + 'smoke-method-map + 'method))))) + (cmp (the smoke-index (method-cmp method class-id name)))) + (declare (type smoke-index cmp) + (dynamic-extent method)) + (if (< cmp 0) + (setf start (1+ index)) + (if (> cmp 0) + (setf end (1- index)) + (return-from find-method-for-class index)))))) + -1) + +(defmacro push-candidate-method (index name argument-count class methods + const-p) + (with-gensyms (method-map method-index method ambig-index i smoke) + `(let* ((,smoke (smoke ,class)) + (,method-map (mem-aref + (smoke-array-pointer + (smoke-module-method-maps ,smoke)) + 'smoke-method-map + (the smoke-index ,index))) + (,method-index (foreign-slot-value ,method-map 'smoke-method-map 'method)) + (,method (make-smoke-method + :smoke ,smoke + :id (first-unabigious-index + ,smoke + ,method-index)))) + (declare (type smoke-index ,method-index)) + (if (cstring/= ,name + (smoke-method-name ,method)) + nil + (progn + (when (= (the smoke-index ,argument-count) + (the smoke-index (get-arguments-length ,method))) + (if (< ,method-index 0) + (let ((,ambig-index (- ,method-index))) + (declare (type smoke-index ,ambig-index)) + (loop as ,i = (the smoke-index + (mem-aref (smoke-module-ambiguous-method-list + ,smoke) + 'smoke-index + ,ambig-index)) + while (> (the smoke-index ,i) 0) do + (incf ,ambig-index) + (let ((,method (make-smoke-method :smoke ,smoke + :id ,i))) + (unless (and ,const-p (not (const-p ,method))) + (push ,method ,methods))))) + (unless (and ,const-p (not (const-p ,method))) + (push ,method ,methods)))) + t))))) + +(defun viable-functions (name argument-count class &optional const-p) + (declare (optimize (speed 3))) + (with-foreign-string (name name) + (let ((methods)) + (let ((smoke (smoke class))) + (let ((start-index (find-method-for-class name class))) + (declare (type smoke-index start-index)) + (when (>= start-index 0) + (loop for index from start-index downto 1 + while (push-candidate-method index name argument-count class + methods const-p)) + (loop for index from (1+ start-index) + to (the smoke-index (smoke-array-length + (smoke-module-method-maps smoke))) + while (push-candidate-method index name argument-count class + methods const-p))))) + methods))) + +(declaim (inline make-conversion make-exact-match make-promotion + make-number-conversion make-pointer-conversion + make-boolean-conversion make-user-conversion)) +(defstruct conversion + (function-name nil :type (or symbol list function) :read-only t) + (rank -1 :type fixnum :read-only t)) + +(defstruct (exact-match (:include conversion (rank 0)))) + +(defstruct (promotion (:include conversion (rank 1)))) + +(defstruct (number-conversion (:include conversion (rank 2)))) + +(defstruct (pointer-conversion (:include conversion (rank 3))) + (from (find-class t) :type class :read-only t) + (to (find-class t) :type class :read-only t)) + +(defstruct (boolean-conversion (:include conversion (rank 4)))) + +(defstruct (user-conversion (:include conversion (rank 5)))) + +(defgeneric conversion<= (conversion1 conversion2) + ;; 13.3.3.2 Ranking implicit conversion sequences + ;; 4 + (:method (conversion1 conversion2) + (declare (optimize (speed 3))) + (and (not (null conversion1)) + (or (null conversion2) + (<= (the fixnum (conversion-rank conversion1)) + (the fixnum (conversion-rank conversion2)))))) + (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion)) + (declare (optimize (speed 3))) + (if (eq (pointer-conversion-from conversion1) + (pointer-conversion-from conversion2)) + ;; A->B < A->C <=> B subclass of C + (subtypep (pointer-conversion-to conversion1) + (pointer-conversion-to conversion2)) + (if (eq (pointer-conversion-to conversion1) + (pointer-conversion-to conversion2)) + ;; B->A < C->A <=> B subclass of C + (subtypep (pointer-conversion-from conversion1) + (pointer-conversion-from conversion2)) + nil)))) + +(defgeneric conversion= (conversion1 conversion2) + (:method (conversion1 conversion2) + (and (conversion<= conversion1 conversion2) + (conversion<= conversion2 conversion1))) + (:method ((conversion1 (eql nil)) (conversion2 (eql nil))) + t)) + +(defun max-conversion (conversion1 conversion2) + "Returns the greater conversion of CONVERSION1 and CONVERSION2." + (if (null conversion2) + conversion1 + (if (conversion<= conversion1 conversion2) + conversion2 + conversion1))) + +(defmacro make-match (type &optional (name ''identity) (argument nil) + &rest args) + (flet ((conversion-function (name &optional arg) + (if arg + `(if (using-typep) + `(,,name + ,(if (typep ,arg 'class) + `(find-class ',(class-name ,arg)) + `(find-smoke-method (find-class ,(class-name + (find-smoke-class + (get-class ,arg)))) + ,(name ,arg)))) + #'(lambda (object) + (funcall (fdefinition ,name) + object ,arg))) + `(if (using-typep) + ,name + (fdefinition ,name))))) + `(,(symbolicate 'make- (eval type)) + :function-name ,(conversion-function name argument) + ,@args))) + +(defun+using-type get-conversion-sequence object (object type &optional user) + "Retrains a conversion sequence to convert a instance of type CLASS +to an instance of type TYPE. When USER is true user conversions are considered." + (if-let (match (call-using-type exact-match object type)) + (if (eql t match) + (make-match 'exact-match) + (make-match 'exact-match match)) + (or (call-using-type promotion object type) + (call-using-type conversion object type) + (and user + (call-using-type user-conversion object type))))) + +(defun+using-types standard-conversion-sequence (method classes &optional user) + "Returns the conversion sequences to convert the arguments of types CLASSES +to the types required by METHOD." + (if (null classes) + (values (make-match 'exact-match) nil) + (let ((max-rank) + (conversions)) + (loop for type in (arguments method) + for class in classes do + (let ((rank (call-using-type get-conversion-sequence class type user))) + (when (null rank) + (setf max-rank nil) + (return nil)) + (setf max-rank (max-conversion rank max-rank)) + (push (conversion-function-name rank) conversions))) + (values max-rank (reverse conversions))))) + +(defun+using-types conversion-sequence (method classes) + (call-using-types standard-conversion-sequence method classes t)) + +(defun+using-types find-best-viable-function (name arguments class + &optional const-p) + "Returns the method named NAME of class CLASS that can be called +using arguments of types TYPES with the lowest conversion sequence." + (call-using-types find-best-viable-function2 + (function-using-types conversion-sequence) + name arguments class const-p)) + +(defun+using-types find-best-viable-function2 (get-sequence name objects class + &optional const-p) + (when (and (using-typep) + (not (typep class 'smoke-standard-class))) + (throw 'unspecific-type class)) + (let ((viable-functions (viable-functions name (length objects) + class const-p)) + (best-rank) + (best-method) + (conversions)) + (if (null viable-functions) + (dolist (class (closer-mop:class-direct-superclasses class) + (values best-method nil)) + (when (typep class 'smoke-standard-class) + (multiple-value-bind (method conversions) + (call-using-types find-best-viable-function2 get-sequence name objects class const-p) + (when method + (return (values method conversions)))))) + (loop for method in viable-functions + finally (return (values best-method conversions)) do + (block next + (multiple-value-bind (rank method-conversions) + (funcall get-sequence method objects) + (when (and rank (conversion<= rank best-rank)) + (when (conversion= rank best-rank) + ;; FIXME catch all ambigious overloads + (if const-p + (error "Ambigious overload ~A." method) + (when (const-p method) + ;; assume that the previous method is a non + ;; const one and thus more specific. + (return-from next)))) + (setf best-rank rank) + (setf best-method method) + (setf conversions method-conversions) + (when (and (conversion= rank (make-match 'exact-match)) + (not (xor const-p (const-p method)))) + (return (values method conversions)))))))))) + +(defvar *from-lisp-translations* (make-hash-table :test 'equal)) + +(defmacro define-from-lisp-translation (type-names lisp-type + &optional + (conversion-function-name 'identity)) + "Defines a translation from LISP-TYPE to the C++ types TYPE-NAMES using +the function CONVERSION-FUNCTION-NAME." + `(progn ,@(loop for type-name in (ensure-list type-names) + collect `(setf (gethash ,type-name *from-lisp-translations*) + #'(lambda (type type-p) + (and (if type-p + (multiple-value-bind (value valid-p) + (subtypep type ',lisp-type) + (unless valid-p + (throw 'unspecific-type type)) + value) + (typep type ',lisp-type)) + ',conversion-function-name)))))) + +(define-from-lisp-translation ("void*" "const void*" "void**" "const void**") + foreign-pointer) + +;; FIXME grovel this? +(deftype c-integer (ctype) + (let ((bits (* 8 (foreign-type-size ctype)))) + (if (starts-with-subseq + (symbol-name :unsigned) + (symbol-name ctype)) + `(unsigned-byte ,bits) + `(signed-byte ,bits)))) + + +(defun+using-type exact-match object (object type) + "Test for an exact match." + (case (type-id type) + (0 (when-let (test (gethash (name type) *from-lisp-translations*)) + (funcall test object (using-typep)))) + (1 (object.typep 'boolean)) + (2 (object.typep 'standard-char)) + (3 (object.typep '(c-integer :unsigned-char))) + (4 (object.typep '(c-integer :short))) + (5 (object.typep '(c-integer :unsigned-short))) + (6 (object.typep '(c-integer :int))) + (7 (object.typep '(c-integer :unsigned-int))) + (8 (object.typep '(and (c-integer :long) + (not (c-integer :int))))) + (9 (object.typep '(and (c-integer :unsigned-long) + (not (c-integer :unsigned-int))))) + (10 (object.typep 'single-float)) + (11 (object.typep 'double-float)) + (12 (when (object.typep 'enum) + (when (using-typep) + (throw 'unspecific-type object)) + (smoke-type= type (enum-type object)))) + (13 (and (object.typep 'smoke-standard-object) + (smoke-type= (get-class type) (object.type-of)))))) + + +(defun make-cleanup-pointer (pointer cleanup-function) + "Returns a pointer that calls CLEANUP-FUNCTION with pointer as argument +when it is finalized." + (let ((address (pointer-address pointer))) + (tg:finalize pointer #'(lambda () + (funcall cleanup-function + (make-pointer address)))))) + +(defun make-auto-pointer (pointer) + "Returns a pointer that frees the memory at POINTER when it is finalized." + (make-cleanup-pointer pointer #'foreign-free)) + +(defun coerce-c-string (string) + (make-auto-pointer (foreign-string-alloc string))) + +(defun coerce-from-enum (enum) + (cxx-support:value enum)) + +(defun coerce-double-float (number) + (float number 0d0)) + +(defun coerce-single-float (number) + (float number 0f0)) + +(defun coerce-to-enum (number) + ;; we can skip the enum type because it is not checked at this + ;; point. + (make-instance 'enum :value number)) + +;; FIXME incomplete +(defun+using-type promotion object (object type) + (declare (smoke-type type)) + (case (type-id type) + (0 (when (and (string= (name type) "const char*") + (object.typep 'string)) + (make-match 'promotion 'coerce-c-string))) + (6 (when (object.typep 'enum) + (make-match 'promotion 'coerce-from-enum))) + (7 (when (object.typep 'enum) + (make-match 'promotion 'coerce-from-enum))) + (10 (when (object.typep 'real) + (make-match 'promotion 'coerce-single-float))) + (11 (when (object.typep 'real) + (make-match 'promotion 'coerce-double-float))) + (12 (when (object.typep '(integer 0)) + (make-match 'promotion 'coerce-to-enum))))) + +(declaim (inline coerce-to-class)) +(defun coerce-cast (object to-class) + (cast object to-class)) + +(defun coerce-to-void (object) + object) + +(defun+using-type conversion-cast object (object type) + (when (and (class-p type) + (object.typep 'smoke-standard-object) + (derived-p (object.type-of) (get-class type)) + (find-smoke-class (get-class type))) + (make-match 'pointer-conversion + 'coerce-cast + (find-smoke-class (get-class type)) + :from (object.type-of) + :to (find-smoke-class (get-class type))))) + +(defun+using-type conversion-void object (object type) + (when (and (string= (name type) "void*") + (object.typep 'smoke-standard-object)) + (make-match 'pointer-conversion + 'coerce-void + nil + :from (object.type-of) + :to (find-class 't)))) + +(defun+using-type conversion-pointer object (object type) + ;; Not using pointer-p to allow passing a raw pointer for objects on + ;; the stack and references. + ;; (e.g.: for qInstallMsgHandler(QtMsgHandler) ) + ;; + ;; FIXME this breaks passing pointers to references. + ;; + ;; e.g.: calling the function foo(QByteArray& foo) with + ;; (foo pointer) assumes pointer to point to a QByteArray, but + ;; actually the conversion sequence QByteArray(pointer) should be + ;; used. When pointer is a null pointer it fails horribly!. + ;; + ;; But it is needed for passing the int pointer in QApplication(int&, char**). + (when (and (or (= 0 (type-id type)) ; voidp + (= 13 (type-id type))) ; class + (object.typep 'foreign-pointer)) + (make-match 'pointer-conversion 'identity nil + :from (find-class 't) + :to (find-class 't)))) ;; FIXME get the class when applicable + + +(defun+using-type conversion object (object type) + (or (call-using-type conversion-cast object type) + (call-using-type conversion-void object type) + (call-using-type conversion-pointer object type))) + +(defun+using-type user-conversion object (object type) + (or (call-using-type operator-conversion object type) + (call-using-type constructor-conversion object type))) + +(defun conversion-operator-name (to-type) + (concatenate 'string + "operator " + (if (class-p to-type) + (name (get-class to-type)) + (name to-type)))) + +(defun coerce-to-type (object method) + (pointer-call method (pointer object))) + +(defun+using-type operator-conversion object (object type) + (when (object.typep 'smoke-standard-object) + (let ((method (find-smoke-method (object.type-of) + (conversion-operator-name type)))) + (when (valid-p method) + (if (pointer-p type) + (make-match 'user-conversion + 'coerce-to-type + method) + (make-match 'user-conversion + (lispify (name method) :cxx))))))) + +(declaim (inline coerce-to-class)) +(defun coerce-to-class (object to-class) + (make-instance to-class + :args (list object))) + +(defun+using-type constructor-conversion object (object type) + (when (class-p type) + (handler-case + (let ((to-class (find-smoke-class (get-class type) nil))) + (when (and to-class + (call-using-types find-best-viable-function2 + (if (using-typep) + #'standard-conversion-sequence-using-types + #'standard-conversion-sequence) + (constructor-name (get-class type)) + (list object) to-class)) + (make-match 'user-conversion + 'coerce-to-class + to-class))) + ;; When the correspoinding Lisp module is not loaded, we ignore + ;; the overload. + (lisp-module-not-loaded ())))) + +(defun call-sequence (method object sequence &rest args) + (s-call method object + (mapcar #'(lambda (conversion argument) + (funcall conversion argument)) + sequence args))) + +(defun format-no-applicable-cxx-method (stream name class arguments) + (format stream + "No applicable method ~S of ~A for ~S. +Candidates are:~{~T~A~%~}." + name class arguments + (mapcar #'signature + (viable-functions name + (length arguments) + (smoke-class-of class))))) + +(define-condition no-applicable-cxx-method (error) + ((method :initarg :method :reader condition-method) + (class :initarg :class :reader condition-class) + (arguments :initarg :arguments :reader condition-arguments)) + (:report (lambda (condition stream) + (format-no-applicable-cxx-method stream + (condition-method condition) + (condition-class condition) + (condition-arguments condition))))) + +(defun call-using-args (object-or-class name arguments) + "Calls the method NAME of OBJECT-OR-CLASS with ARGUMENTS." + (declare (optimize (speed 3)) + (type (or smoke-standard-class smoke-standard-object) + object-or-class)) + (multiple-value-bind (method sequence) + (#-sbcl find-best-viable-function + #+sbcl find-best-viable-function-cached + name + arguments + (smoke-class-of object-or-class) + (when (typep object-or-class + 'smoke-standard-object) + (const-p object-or-class))) + (when (null method) + (error (make-condition 'no-applicable-cxx-method + :method name + :class object-or-class + :arguments arguments))) + (apply #'call-sequence method + (if (static-p method) + (null-pointer) + (cast object-or-class (get-class method))) + sequence arguments))) + +(defmethod slot-missing (meta-class (class smoke-standard-class) slot-name operation &optional new-value) + (let ((method (find-smoke-method class (lisp-to-cxx (string slot-name))))) + (if (or (not (valid-p method)) (not (static-p method))) + (call-next-method) + (ecase operation + (setf + (handler-case (funcall (fdefinition + (intern + (concatenate 'string "SET-" + (string-upcase + (string slot-name))) + :cxx)) + class new-value) + (undefined-function () + (error "The C++ attribute ~A of ~A is read only." slot-name class)) + (no-applicable-cxx-method (condition) + (if (null (viable-functions (condition-method condition) + (length (condition-arguments condition)) + (condition-class condition))) + (error "The C++ attribute ~A of ~A is read only." slot-name class) + (error condition))))) + (slot-boundp t) + (slot-makunbound (error "Can not unbind the C++ attribute ~A of ~A." slot-name class)) + (slot-value (s-call method (null-pointer))))))) + +(defmethod slot-missing ((class smoke-standard-class) object slot-name operation &optional new-value) + (let ((method (find-smoke-method class (lisp-to-cxx (string slot-name))))) + (if (not (valid-p method)) + (call-next-method) + (ecase operation + (setf + (handler-case (funcall (fdefinition + (intern + (concatenate 'string "SET-" + (string-upcase + (string slot-name))) + :cxx)) + object new-value) + (undefined-function () + (error "The C++ attribute ~A of ~A is read only." slot-name object)) + (no-applicable-cxx-method (condition) + (if (null (viable-functions (condition-method condition) + (length (condition-arguments condition)) + (condition-class condition))) + (error "The C++ attribute ~A of ~A is read only." slot-name object) + (error condition))))) + (slot-boundp t) + (slot-makunbound (error "Can not unbind the C++ attribute ~A of ~A." slot-name object)) + (slot-value (s-call method (cast object (get-class method)))))))) diff -rN -u old-smoke/src/package.lisp new-smoke/src/package.lisp --- old-smoke/src/package.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/package.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,86 @@ +(defpackage #:cxx-support + (:use #:cl) + (:export #:enum + #:enum= + #:enum-logand + #:enum-logior + #:value + #:enum-type + #:enum-case + #:enum-cases + #:enum-ecase)) + +(defpackage #:smoke + (:use #:cl #:cffi #:trivial-garbage #:bordeaux-threads #:cxx-support + #:alexandria) + (:export #:call + #:c-integer + + #:class-p + #:class-size + #:const-p + #:id + #:name + #:pointer + #:pointer-p + #:size + #:smoke + #:stack-p + #:type-foreign-keyword + #:type-id + #:type-size + #:virtual-destructor-p + + #:convert-argument + #:cxx-bool + + #:define-from-lisp-translation + #:define-to-lisp-translation + #:*to-lisp-translations* + + #:define-pointer-typedef + #:define-smoke-module + + #:define-takes-ownership + #:delete-object + #:remove-object + + #:eval-startup + + #:get-smoke-variable-for-pointer + #:init + #:object-to-lisp + + #:make-auto-pointer + #:make-cleanup-pointer + + #:make-smoke-classes + #:make-smoke-type + #:no-applicable-cxx-method + #:smoke-call + #:upcast + + #:smoke-standard-object + #:smoke-type + #:smoke-type= + + #+sbcl #:save-bundle)) + +(defpackage #:cxx + (:use) ;; do not use #:cl + (:export #:class + + #:= ;; These are defined in :qt since we need QGlobalSpace + #:/= + #:< #:<= + #:> #:>= + #:incf + #:decf + #:+ + #:- + #:* + #:/ + #:1+ + #:1- + + #:aref)) diff -rN -u old-smoke/src/run-test.lisp new-smoke/src/run-test.lisp --- old-smoke/src/run-test.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/run-test.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,16 @@ +#| +exec sbcl --noinform --noprint --disable-debugger --load $0 --end-toplevel-options "$@" +|# + +;(asdf:operate 'asdf:load-op 'smoke :verbose nil) +;(require :sb-cover) +;(declaim (optimize sb-cover:store-coverage-data)) +;(asdf:oos 'asdf:load-op :smoke :force t) +(require :smoke-tests) +(in-package :smoke-tests) +(setup) +(5am:run!) +;(smoke-destruct *kde-binding*) +;(smoke-destruct *qt-binding*) +;(sb-cover:report "./report/") +(sb-ext:quit) diff -rN -u old-smoke/src/sb-optimize.lisp new-smoke/src/sb-optimize.lisp --- old-smoke/src/sb-optimize.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/sb-optimize.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,159 @@ +(in-package :smoke) + +(declaim (optimize (debug 3))) + +(defmacro catch-try ((tag &optional catch-result) catch-form &body body) + "Catch TAG in the BODY forms. When TAG is throw CATCH-RESULT is bound +to the thrown values and result of CATCH-FORM is returned. Otherwise +the result of BODY is returned and CATCH-FORM is not evaluated." + (flet ((catch-block (tag return-block body) + `(catch ,tag + (return-from ,return-block + ,@body)))) + (let ((return-block (gensym))) + `(block ,return-block + ,(if catch-result + `(let ((,catch-result ,(catch-block tag return-block body))) + ,catch-form) + `(progn ,(catch-block tag return-block body) + ,catch-form)))))) + +(defun type-specifier (lvar) + (let ((type (sb-kernel:type-specifier (sb-c::lvar-type lvar)))) + (if (subtypep type 'smoke-standard-object) + (find-class type) + type))) + + +(defun give-up-transform (&rest args) + (apply #'sb-c::give-up-ir1-transform args)) + +(defmacro define-transform (name lambda-list &body body) + `(sb-c:deftransform ,name (,lambda-list) + ,@body)) + +(defmacro define-known (name) + `(sb-c:defknown ,name * *)) + +(defun method-form (method) + `(make-smoke-method + :id ,(id method) + :smoke (eval ,(get-smoke-variable-for-pointer + (smoke method))))) + +(defun sequence-form (sequence arguments) + (mapcar #'(lambda (sequence argument) + (if (symbolp sequence) + `(,sequence ,argument) + `(,(first sequence) ,argument ,@(rest sequence)))) + sequence arguments)) + + +(defmacro define-resolve-at-compile-time (gf-name) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (define-known ,gf-name) + (sb-c:defoptimizer (,gf-name derive-type) ((object &rest args)) + (catch-try ('unspecific-type) sb-c::*wild-type* + (let ((method (find-best-viable-function-using-types + ,(name (fdefinition gf-name)) + (mapcar #'type-specifier args) (type-specifier object)))) + (if (and method (class-p (return-type method))) + (sb-kernel:single-value-specifier-type + (find-smoke-class (get-class (return-type method)))) + sb-c::*wild-type*)))) + (define-transform ,gf-name (object &rest args) + (when (null args) + (give-up-transform "No arguments.")) + (catch-try ('unspecific-type reason) + (give-up-transform "Could not resolve overload at compile time: ~A" reason) + (multiple-value-bind (method sequence) + (find-best-viable-function-using-types + ,(name (fdefinition gf-name)) + (mapcar #'type-specifier args) + (type-specifier object)) + (let ((argument-names (make-gensym-list (length args)))) + (when (null method) + (give-up-transform "No applicable method.")) + (if (static-p method) + `(s-call ,(method-form method) + (null-pointer) + (list ,@(sequence-form + sequence args))) + `(lambda (object ,@argument-names) + (s-call ,(method-form method) + ,(if (eql (type-specifier object) + (find-smoke-class (get-class method))) + `(pointer object) + `(cast object + (find-class (quote ,(class-name + (find-smoke-class + (get-class method))))))) + (list ,@(sequence-form + sequence argument-names))))))))))) + + +;;; Cache overload resolution / method lookup + +;;; FIXME the cached lookup should be faster +;;; +;;; cache return value conversion +;;; +;;; Using the gf symbol instead of the method name would be better, +;;; althoug we would have to invent one for constructors. +;;; +;;; Since the -using-types stuff was intended for for compile time +;;; expansion it is not that well suited for this. i.e. passing +;;; closures would be better than the actual syntax. +;;; +;;; For qt.tests the uncached calls make up 30 % of all calls. +;;; qt.examples:colliding-mice (run for ~1 min) gets 20 % uncached +;;; calls and qt.examples:class-browser get 10 %. (20 February 2010) + +(sb-int:defun-cached (find-best-viable-function-using-layouts-cached + :hash-function (lambda (name arguments + class const-p) + (declare (string name) + (list arguments) + (sb-c::layout class) + (boolean const-p)) + (logand + (logxor + (sxhash name) + (the fixnum + (reduce + #'logxor + (mapcar #'sb-c::layout-clos-hash + arguments))) + (sxhash class) + (sxhash const-p)) + #x1FF)) + :hash-bits 9) + ((name equal) (arguments equal) (class eq) (const-p eq)) + (declare (optimize (speed 3)) + (inline find-best-viable-function-using-types)) + (multiple-value-bind (method conversion-sequence) + (find-best-viable-function-using-types + name (mapcar #'sb-pcl::wrapper-class* arguments) + class const-p) + (list method (mapcar #'(lambda (s) + (if (symbolp s) + (fdefinition s) + #'(lambda (x) + (declare (optimize (speed 3))) + (funcall (fdefinition (first s)) + x + (eval (second s)))))) + conversion-sequence)))) + +(declaim (inline find-best-viable-function-cached)) +(defun find-best-viable-function-cached (name arguments class const-p) + (declare (optimize (speed 3))) + (catch 'unspecific-type + (return-from find-best-viable-function-cached + (values-list + (find-best-viable-function-using-layouts-cached + name + (mapcar #'(lambda (o) (sb-c::layout-of o)) arguments) + class + const-p)))) + (find-best-viable-function name arguments class const-p)) diff -rN -u old-smoke/src/smoke-to-clos.lisp new-smoke/src/smoke-to-clos.lisp --- old-smoke/src/smoke-to-clos.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/smoke-to-clos.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,180 @@ +(in-package :smoke) + +(defun constant-definition (package method smoke) + "Returns an expression that defines a constant for the enum METHOD. +The second return value is the expression to export the constant." + (let ((symbol + (if (or (string= (name (get-class method)) + "Qt") + (string= (name (get-class method)) + "QGlobalSpace")) + (lispify (concatenate 'string "+" (name method) + "+") + package) + (lispify (concatenate 'string + (name (get-class method)) + ".+" + (name method) "+") + package)))) + (values + (if (= 8 (type-id (return-type method))) + `(define-constant ,symbol ;; a long, not really an enum. + ,(enum-call method)) + `(define-constant ,symbol + (make-instance 'enum + :value ,(enum-call method) + :type (make-instance 'smoke-type + :id ,(id (return-type method)) + :smoke ,smoke)) + :test #'enum=)) + symbol))) + +(defun static-method-symbol (package method) + "Returns the lisp symbol for the static method METHOD." + (let ((class (get-class method))) + (lispify (concatenate 'string + (if (string= (name class) + "QGlobalSpace") + nil + (concatenate 'string + (name class) + ".")) + (name method)) + package))) + +(defun static-method-definition (package method &optional (argument-count -1)) + "Returns an expression to define a function for the static METHOD. +The second return value is the expression to export the function." + (let* ((class (get-class method)) + (method-name (name method)) + (name (static-method-symbol package method))) + (values + `(defun ,name ,(if (< argument-count 0) + '(&rest args) + (make-lambda argument-count)) + (call-using-args + (find-class (quote ,(lispify (name class) + (if (string= (name class) + "QGlobalSpace") + *package* ;; See #'MAKE-SMOKE-CLASSES + package)))) + ,method-name + ,(if (< argument-count 0) + 'args + `(list ,@(make-lambda argument-count))))) + name))) + +(defun ensure-generic-methods (symbols-names) + "Ensures the generic functions for SYMBOLS-NAMES." + (declare (list symbols-names) + (optimize (speed 3))) + (dolist (symbol-name symbols-names) + (ensure-generic-function (first symbol-name) + :cxx-name (rest symbol-name) + :generic-function-class 'smoke-gf + :lambda-list '(object &rest args)) + (export (first symbol-name) :cxx))) + +(defun setf-method-definition (method) + `(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object) + (,(lispify (name method) :cxx) object new-value) + new-value)) + +(defmacro sizes= ((smoke)&rest arrays) + `(and ,@(loop for array in arrays collect + `(= (smoke-array-length (,array ,smoke)) + ,(smoke-array-length (funcall (fdefinition array) + (eval smoke))))))) + +(defmacro check-recompile (smoke) + "Raises an error or tries to recompile when the fasl of the define-classes-and-gfs +was not compiled against the current smoke module." + (with-unique-names (restart) + `(eval-when (:load-toplevel :execute) + (unless (sizes= (,smoke) + smoke-module-methods + smoke-module-method-names + smoke-module-method-maps + smoke-module-classes + smoke-module-types) + (let ((,restart (find-restart 'asdf:try-recompiling))) + (if ,restart + (invoke-restart ,restart) + (error "The smoke module ~A changed, you need to recompile the lisp file." + (smoke-get-module-name (smoke-module-pointer ,smoke))))))))) + +(defmacro define-classes-and-gfs (package smoke) + "Process the C++ methods of the Smoke module SMOKE. +Expands to DEFUNs for static methods, DEFINE-CONSTANTs for enum methods +and a function do define the generic methods a load-time." +;;; symbol - id pairs are stored in the hash-tables to prevent the +;;; multiple definition of a function with the same name. + (let ((generics (make-hash-table)) + (constants) + (functions) + (function-symbols (make-hash-table)) + (setf-function-symbols (make-hash-table)) + (exports)) + (map-methods + #'(lambda (method) + (when (and (enum-p method) + ;; qt.network has QIODevice::NotOpen(), but the + ;; class is external (workaround). + (not (external-p (get-class method)))) + (multiple-value-bind (def export) (constant-definition package method smoke) + (push def + constants) + (push export exports))) + (when (and (not (destructor-p method)) + (not (constructor-p method)) + (not (enum-p method)) + (not (eql nil (name method))) + (string/= (name method) "tr")) ;; we have a custom qt:tr function + (let ((name (name method))) + (when (and (starts-with-subseq "set" name) + (> (length name) 3) + (upper-case-p (char name 3)) + (= 1 (get-arguments-length method))) + (unless (nth-value 1 (gethash (lispify name :cxx) setf-function-symbols)) + (setf (gethash (lispify name :cxx) setf-function-symbols) t) + (push (setf-method-definition method) functions))) + (let ((lisp-name (lispify name "CXX"))) + (unless (and (gethash lisp-name generics) (attribute-p method)) + (setf (gethash lisp-name generics) name)))) + (when (static-p method) + (let* ((function-symbol (static-method-symbol package method)) + (methods (gethash function-symbol function-symbols))) + (unless (fboundp function-symbol) ;; do not overwrite + ;; existing functions e.g. qInstallMsgHandler of + ;; qt.core with that of qt.gui which causes a + ;; segfault when loading from an saved image. + (setf (gethash function-symbol function-symbols) + (if methods (- (id method)) (id method)))))))) + (eval smoke)) + (loop for id being the hash-values of function-symbols do + (let ((method (make-smoke-method + :smoke (eval smoke) + :id (abs id)))) + (multiple-value-bind (definition export) + (static-method-definition + package + method + (if (< 0 id) + (get-arguments-length method) + -1)) + (push definition functions) + (push export exports)))) + `(progn (check-recompile ,smoke) + ,@functions + (eval-startup (:compile-toplevel :load-toplevel :execute) + ;; FIXME when loading the Lisp image we no longer need + ;; to call #'ensure-class, but the class-map needs still + ;; to be populated by #'add-id-class-map and #'add-id; + ;; For now we ignore the negligible overhead. + (make-smoke-classes ,package ,smoke)) + (eval-when (:load-toplevel :execute) + (ensure-generic-methods ',(hash-table-alist generics))) + ,@constants + (eval-when (:load-toplevel :execute) + (export (quote ,exports) ,package))))) + diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp --- old-smoke/src/smoke.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/smoke.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,215 @@ +;;; Copyright (C) 2009, 2010 Tobias Rautenkranz +;;; +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see . +;;; +;;; As a special exception, the copyright holders of this library give you +;;; permission to link this library with independent modules to produce an +;;; executable, regardless of the license terms of these independent +;;; modules, and to copy and distribute the resulting executable under +;;; terms of your choice, provided that you also meet, for each linked +;;; independent module, the terms and conditions of the license of that +;;; module. An independent module is a module which is not derived from or +;;; based on this library. If you modify this library, you may extend this +;;; exception to your version of the library, but you are not obligated to +;;; do so. If you do not wish to do so, delete this exception statement +;;; from your version. + +(in-package #:smoke) + +(declaim (inline call-s-method)) +(defun call-s-method (method object-pointer stack-pointer) + (foreign-funcall-pointer + (foreign-slot-value (smoke-class-pointer (get-class method)) + 'smoke-class 'class-function) + () + smoke-index (foreign-slot-value (smoke-method-pointer method) + 'smoke-method 'method) + :pointer object-pointer + smoke-stack stack-pointer + :void)) + +(defun s-call (method object-pointer &optional (args nil)) + (with-stack (stack args (arguments method) ) + (call-s-method method object-pointer (call-stack-pointer stack)) + (type-to-lisp (call-stack-pointer stack) (return-type method)))) + +(defun pointer-call (method object-pointer &optional (args nil)) + (with-stack (stack args (arguments method) ) + (call-s-method method object-pointer (call-stack-pointer stack)) + (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'class))) + +(defun smoke-call (class pointer method-name &optional (args nil)) + (s-call (make-smoke-method-from-name class method-name) pointer args)) + +(defun enum-call (method) + "Return the enum value for METHOD." + ;; FIXME: + ;; + ;; we could use static call, but QGraphicsEllipseItem::Type has + ;; wrongly QGraphicsGridLayout as return type. Smoke ignores case + ;; and confuses it with the member function type() ?? (27.2.09) + ;; + (assert (enum-p method)) + (with-stack (stack nil nil) + (call-s-method method (null-pointer) (call-stack-pointer stack)) + (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'long))) + +(defun delete-pointer (pointer class) + "Destructs the object at POINTER of type CLASS. +Calls the destructor and frees the memory." + (declare (optimize (speed 3))) + (let ((method-name (concatenate 'string "~" (constructor-name class)))) + (s-call (make-smoke-method-from-name class method-name) pointer))) + +(defun delete-object (object) + (delete-pointer (pointer object) (class-of object)) + (setf (slot-value object 'pointer) (null-pointer))) + +(eval-startup (:load-toplevel :execute) + (defparameter *binding* (smoke-construct-binding + (callback destructed) + (callback dispatch-method))) + (defparameter *no-dispatch-binding* (smoke-construct-binding + (callback destructed) + (null-pointer)))) + +(defun set-binding (object) + "Sets the Smoke binding for OBJECT, that receives its callbacks." + (declare (optimize (speed 3))) + (let ((class (class-of object))) + (with-foreign-object (stack 'smoke-stack-item 2) + (setf (foreign-slot-value (mem-aref stack 'smoke-stack-item 1) + 'smoke-stack-item 'voidp) + (if (typep class 'cxx:class) + *binding* + *no-dispatch-binding*)) + (foreign-funcall-pointer + (foreign-slot-value (smoke-class-pointer class) + 'smoke-class 'class-function) + () + smoke-index 0 ;; set binding method index + :pointer (pointer object) + smoke-stack stack + :void)))) + +(defun init (smoke module) + "Returns the a new Smoke binding for the Smoke module SMOKE." + (use-foreign-library libclsmoke) + (setf (smoke-module-pointer module) smoke) + (init-smoke-module module) + (setf (gethash (pointer-address smoke) *smoke-modules*) module) + module) + +(let ((pointer-symbol-map (make-hash-table))) + ;; Used by make-load-form for enums to reference the smoke module. + (defun register-smoke-module-var (symbol) + "Registers SYMBOL of a variable containing a pointer to a Smoke module." + (setf (gethash (pointer-address (smoke-module-pointer (eval symbol))) + pointer-symbol-map) + symbol)) + (defun get-smoke-variable-for-pointer (pointer) + "Returns the SYMBOL of the variable whose value is POINTER." + (gethash (pointer-address pointer) pointer-symbol-map))) + +(defun call (object method-name &rest args) + (smoke-call (class-of object) (pointer object) + method-name args)) + +(defmethod documentation ((class smoke-standard-class) (doc-type (eql 't))) + (declare (optimize (speed 3))) + (format nil "~@[~A~%~]C++ name: ~A" (call-next-method) (name class))) + +(defmethod documentation ((gf smoke-gf) (doc-type (eql 't))) + (declare (optimize (speed 3))) + (let ((methods (all-methods (name gf)))) + (format nil "~@[~A~%~]~{~T~A~%~}" + (call-next-method) + (sort (mapcar #'method-declaration methods) #'string<=)))) + +(declaim (inline cstring=)) +(defun cstring= (string1 string2) + "Returns T when the C strings STRING1 and STRING2 are equal + and NIL otherwise." + (zerop (strcmp string1 string2))) + +(defun all-methods (name) + "Returns a list of all methods named NAME." + (declare (optimize (speed 3))) + (with-foreign-string (name name) + (let ((methods)) + (maphash + #'(lambda (address module) + (declare (ignore address)) + (map-methods #'(lambda (method) + (when (and (cstring= name (smoke-method-name method)) + (not (enum-p method))) + (push (make-smoke-method + :id (smoke-method-id method) + :smoke (smoke-method-smoke method)) + methods))) + module)) + *smoke-modules*) + methods))) + +(defun fgrep-methods (smoke str) + (map-methods #'(lambda (method) + (when (search str (name method)) + (princ (method-declaration method)) + (terpri))) + smoke)) + +(defmacro define-smoke-module (package library + (variable variable-name) + (init-function function-name)) + "Define a Smoke module." + (let ((smoke-module (intern "*SMOKE-MODULE*"))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (define-foreign-library ,library + (:darwin ,(format nil "~(~A~).3.dylib" library)) + (:unix ,(format nil "~(~A~).so.3" library)) + (t (:default ,(format nil "~(~A~)" library))))) + (eval-startup (:compile-toplevel :execute) + (load-foreign-library ',library)) + + (eval-startup (:compile-toplevel :execute) + (defcvar (,variable ,variable-name :read-only t :library ,library) + :pointer) + (defcfun (,init-function ,function-name :library ,library) + :void)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,smoke-module (make-smoke-module))) + (eval-startup (:compile-toplevel :execute) + (,init-function) + (init ,variable ,smoke-module) + (register-smoke-module-var ',smoke-module)) + (define-classes-and-gfs ,package ,smoke-module)))) + +(defun fgrep-classes (smoke str) + (map-classes #'(lambda (class) + (when (search str (name class)) + (format t "~A~%" (name class)))) + smoke)) + +(defmacro define-takes-ownership (method lambda-list object) + "Declares METHOD transfers the ownership of OBJECT to the +first argument of LAMBDA-LIST." + `(defmethod ,method :before ,lambda-list + (declare (ignorable ,@(loop for arg in (rest lambda-list) collect + (if (consp arg) + (first arg) + arg)))) + (transfer-ownership-to ,object ,(if (consp (first lambda-list)) + (first (first lambda-list)) + (first lambda-list))))) diff -rN -u old-smoke/src/test.lisp new-smoke/src/test.lisp --- old-smoke/src/test.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/test.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,10 @@ +#| +exec sbcl --noinform --load $0 --end-toplevel-options "$@" +|# + +(sb-ext:disable-debugger) +(require :smoke) +(in-package :smoke) +(setup) +(test) +(sb-ext:quit) diff -rN -u old-smoke/src/tests.lisp new-smoke/src/tests.lisp --- old-smoke/src/tests.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/tests.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,5 @@ +(in-package :smoke) + +(5am:def-suite smoke-suite) +(5am:in-suite smoke-suite) + diff -rN -u old-smoke/src/using-type.lisp new-smoke/src/using-type.lisp --- old-smoke/src/using-type.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/using-type.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,91 @@ +;;; NOTE -using-type is disabled for now, since it is not used. + +(in-package :smoke) + +(defmacro with-object-as-object (object &body body) + `(macrolet ((,(symbolicate object '.typep) + (type) + `(typep ,',object ,type)) + (,(symbolicate object '.type-of) () + `(class-of ,',object)) + (using-typep () nil) + (call-using-types (function-name &rest args) + `(,function-name ,@args)) + (call-using-type (function-name &rest args) + `(,function-name ,@args))) + ,@body)) + +(defun typep-using-type (object-type type) + "Returns true when OBJECT-TYPE is a subtype of TYPE, +false when it is not." + (declare (values (member t nil :maybe))) + (multiple-value-bind (subtype-p valid-p) + (subtypep object-type type) + (if subtype-p + t + (if valid-p + (multiple-value-bind (subtype-p valid-p) + (subtypep type object-type) + (if subtype-p + (throw 'unspecific-type (values object-type type)) + (if valid-p + (if (and (subtypep type 'integer) + (not (integer-types-disjunct-p object-type type))) + (throw 'unspecific-type (values object-type type)) + nil) + (throw 'unspecific-type (values object-type type))))) + (throw 'unspecific-type (values object-type)))))) + +(defmacro with-object-as-type (object-type &body body) + `(macrolet ((,(symbolicate object-type '.typep) + (type) + `(typep-using-type ,',object-type ,type)) + (,(symbolicate object-type '.type-of) () + (quote ,object-type)) + (using-typep () t) + (call-using-types (function-name &rest args) + `(,(symbolicate function-name '-using-types) + ,@args)) + (call-using-type (function-name &rest args) + `(,(symbolicate function-name '-using-type) + ,@args))) + ,@body)) + +(defmacro defun+using-type (name object lambda-list &body body) + "Defines the functions NAME and NAME-using-type where the argument +OBJECT of LAMBDA-LIST is an object respective its type. +For OBJECT the functions OBJECT.typep and OBJECT.type-of can be used." + `(progn + (with-object-as-object ,object + (defun ,name ,lambda-list + ,@body)) + (with-object-as-type ,object + (defun ,(symbolicate name '-using-type) ,lambda-list + ,@body)))) + +(defmacro defun+using-types (name lambda-list &body body) + `(progn (macrolet ((call-using-types (function-name &rest args) + `(,function-name ,@args)) + (call-using-type (function-name &rest args) + `(,function-name ,@args)) + (using-typep () nil) + (function-using-types (name) + `(function ,name))) + (defun ,name ,lambda-list + ,@body)) + (macrolet ((call-using-types (function-name &rest args) + `(,(symbolicate function-name '-using-types) + ,@args)) + (call-using-type (function-name &rest args) + `(,(symbolicate function-name '-using-type) + ,@args)) + (using-typep () t) + (function-using-types (name) + `(function ,(symbolicate name '-using-types)))) + (defun ,(symbolicate name '-using-types) ,lambda-list + ,@body)))) + +(defun integer-types-disjunct-p (type1 type2) + ;; FIXME implement this + (declare (ignore type1 type2)) + nil) diff -rN -u old-smoke/src/utils/get-value.lisp new-smoke/src/utils/get-value.lisp --- old-smoke/src/utils/get-value.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/utils/get-value.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,5 @@ +(in-package #:smoke) + + (defun read-new-value () + (format *query-io* "Enter a new value: ") + (multiple-value-list (eval (read *query-io*)))) diff -rN -u old-smoke/src/utils/image/image.lisp new-smoke/src/utils/image/image.lisp --- old-smoke/src/utils/image/image.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/utils/image/image.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,14 @@ +(in-package :smoke) + +(declaim (inline add-and-run-startup-function)) +(defun add-and-run-startup-function (function) + (add-startup-function function) + (funcall function)) + +(defmacro eval-startup ((&rest situations) &body body) + "Runs BODY when it is loaded (when the source is loaded and also +when the Lisp image is loaded)." + `(eval-when (,@situations :load-toplevel) + (add-and-run-startup-function #'(lambda () + (let ((*package* ,*package*)) + ,@body))))) diff -rN -u old-smoke/src/utils/image/impl/ccl.lisp new-smoke/src/utils/image/impl/ccl.lisp --- old-smoke/src/utils/image/impl/ccl.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/utils/image/impl/ccl.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,11 @@ +(in-package :smoke) + +(defun add-startup-function (function) + (push function ccl:*lisp-startup-functions*)) + +(defmacro eval-on-save (() &body body) + `(eval-when (:load-toplevel) + (push #'(lambda () + (let ((*package* ,*package*)) + ,@body)) + ccl:*save-exit-functions*))) diff -rN -u old-smoke/src/utils/image/impl/sbcl.lisp new-smoke/src/utils/image/impl/sbcl.lisp --- old-smoke/src/utils/image/impl/sbcl.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/utils/image/impl/sbcl.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,20 @@ +(in-package :smoke) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defvar *startup-functions* nil + "Functions to run (in order) on startup.") +(defun add-startup-function (function) + (setf *startup-functions* + (nconc *startup-functions* (list function)))) +(defun run-startup-functions () + (mapcar #'funcall *startup-functions*))) + +(eval-when (:load-toplevel :execute) + (push #'run-startup-functions sb-ext:*init-hooks*)) + +(defmacro eval-on-save (() &body body) + `(eval-when (:load-toplevel) + (push #'(lambda () + (let ((*package* ,*package*)) + ,@body)) + sb-ext:*save-hooks*))) diff -rN -u old-smoke/src/utils/sbcl-bundle.lisp new-smoke/src/utils/sbcl-bundle.lisp --- old-smoke/src/utils/sbcl-bundle.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/utils/sbcl-bundle.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,85 @@ +(in-package :smoke) + +(defun strip-foreign-libraries-path () + (dolist (library sb-alien::*shared-objects*) + (setf (slot-value library 'namestring) + (file-namestring (slot-value library 'pathname))))) + +(defun make-temporary-directory () + (pathname (concatenate 'string (sb-posix:mkdtemp "/tmp/cl-smokeXXXXXX") + "/"))) + +(defmacro with-temporary-directory ((directory) &body body) + "Binds DIRECTORY to the pathname of a temporary directory and executes body:" + `(let ((,directory (make-temporary-directory))) + (unwind-protect (progn ,@body) + (unless (zerop + (sb-ext:process-exit-code + (sb-ext:run-program "/bin/rm" + (list "-r" (namestring ,directory))))) + (cerror "ignore" + "could not remove temporary directory ~A" + ,directory))))) + +(defun save-image (file-name &rest options &key &allow-other-keys) + "Save the lisp image in FILE-NAME." + (let ((pid (sb-posix:fork))) + (if (= 0 pid) + (progn + (strip-foreign-libraries-path) + (apply #'sb-ext:save-lisp-and-die file-name :executable t + options)) + (sb-posix:waitpid pid 0)))) + +(defun write-shell-wrapper (pathname core-name) + (with-open-file (stream pathname :direction :output) + (format stream "#!/bin/sh +cd `dirname \"$0\"` +LD_LIBRARY_PATH=./ exec -a \"$0\" ./~A $@ +" core-name)) + (sb-posix:chmod pathname #o0755)) + +(defun makeself (run-directory directory-name file-name label + &optional (startup-script "") &rest args) + "Make self-extractable archives on Unix +http://megastep.org/makeself/" + ;; make an absolute pathname sine we change the directory. + (let ((file-name (merge-pathnames file-name))) + (flet ((arguments (&rest args) + (format nil "~{~A ~}" args))) + (unless (zerop + (sb-ext:process-exit-code + (sb-ext:run-program + "/bin/sh" + (list "-c" + (apply #'arguments + "cd " (namestring run-directory) " && " + "makeself --nox11" (namestring directory-name) + (namestring file-name) label + startup-script args))))) + (error "Create ~A failed." file-name))))) + +(defun save-bundle (file-name &optional extra-files &rest options &key &allow-other-keys) + "Creates a FILE-NAME.tar.bz2 in the current directory. +This bundle contains a dumped image, the wrapper libraries and a +script to run in. OPTIONS is passed to SB-EXT:SAVE-LISP-AND-DIE." + (with-temporary-directory (dir) + (let ((bundle-dir (merge-pathnames (make-pathname :directory + (list :relative file-name)) + dir))) + (sb-posix:mkdir bundle-dir #o0755) + (dolist (library sb-alien::*shared-objects*) + (sb-ext:run-program + "/bin/cp" (list (namestring (slot-value library 'pathname)) + (namestring bundle-dir)))) + (apply #'save-image (namestring (make-pathname :name "sbcl-core" + :defaults bundle-dir)) + options) + (write-shell-wrapper (make-pathname :defaults bundle-dir + :name "run" + :type "sh") + "sbcl-core") + (dolist (file extra-files) + (copy-file file (merge-pathnames bundle-dir file))) + (makeself dir bundle-dir file-name "sbcl-bundle" + "./run.sh")))) diff -rN -u old-smoke/test-bundle.sh new-smoke/test-bundle.sh --- old-smoke/test-bundle.sh 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/test-bundle.sh 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,12 @@ +#!/bin/sh +if [[ $# -ne 0 ]]; then + echo "Test cl-smoke bundle creation." + echo "Usage: $0" + exit 1 +fi + +MALLOC_CHECK_=3 sbcl --eval '(require :cl-smoke.qt.tests)' \ + --eval '(smoke:save-bundle "qt.test.run")' \ + --eval '(quit)' || exit 1 + +echo "(progn (in-package :qt.tests) (5am:run!) (quit))" | MALLOC_CHECK_=3 ./qt.test.run diff -rN -u old-smoke/test.lisp new-smoke/test.lisp --- old-smoke/test.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/test.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,28 @@ +#| +cmake ./ || exit 1 +make || exit 1 +echo \ +"################ +## Testing sbcl +################" +MALLOC_CHECK_=3 sbcl --noinform --disable-debugger --noprint --load $0 --end-toplevel-options "$@" || exit 1 +echo \ +"############### +## Testing sbcl image +################" + sh ./test-bundle.sh || exit 2 +echo \ +"############### +## Testing ccl +################" +ccl --batch --quiet --load $0 || exit 3 +exit 0 +# Used for testing on darcs record. +|# + +(require :asdf) +(asdf:operate 'asdf:load-op :cl-smoke.smoke) +(asdf:operate 'asdf:test-op :cl-smoke.smoke) + +#+sbcl (sb-ext:quit) +#+ccl (ccl:quit) diff -rN -u old-smoke/tests/test.lisp new-smoke/tests/test.lisp --- old-smoke/tests/test.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/tests/test.lisp 2014-10-06 11:34:02.000000000 +0200 @@ -0,0 +1,3 @@ +;;; :smoke has no test suite, but since :qt depends on :smoke we can use its. + +(mb:test :qt)