/LICENSE
Ignoring non-repository paths: /LICENSE
Tue Jul 13 21:17:41 CEST 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Use libsmokebase instead of libsmokeqtcore.
Sat Apr 3 21:11:26 CEST 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* slot-value access for static attributes using the class instead of an object.
Sat Apr 3 14:04:39 CEST 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* 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 <tobias@rautenkranz.ch>
* 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 <tobias@rautenkranz.ch>
* Improve missing to-lisp-translator error message.
Sat Feb 20 21:56:27 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Allow passing integers as enum arguments.
Sat Feb 20 19:01:21 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix overload resolution exact match for long and ulong.
Sat Feb 20 18:56:48 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Faster no overload resolution method lookup.
Sat Feb 20 18:24:36 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Cache overload resolution on sbcl
Fri Feb 19 22:22:50 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* cleanup #'delete-object & optimize #'constructor-name.
Fri Feb 19 22:10:24 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* No need to construct a SmokeBinding per Smoke module.
Thu Feb 18 20:57:00 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Don't dispatch virtual methods for builtin classes (reduces overhead).
Thu Feb 18 19:31:47 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix casting across Smoke modules.
Wed Feb 17 18:05:35 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* 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 <tobias@rautenkranz.ch>
* Load libsmokeqtcore instead of qt in the default case of cffi:define-foreign-library.
Tue Feb 16 22:52:02 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix derived-p for classes that are external in every module.
Mon Feb 15 16:31:33 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* 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 <tobias@rautenkranz.ch>
* sbcl-bundle requires posix & unix
Thu Feb 4 16:11:29 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Test building libclsmoke.
Wed Feb 3 17:20:56 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* 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 <tobias@rautenkranz.ch>
* Add missing :sb-posix dependency.
Sat Jan 30 15:40:08 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Do not warn on missing parent class.
Tue Jan 26 17:26:09 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix for r1077826. Not instantiable parent classes are external. (QAbstractPrintDialog)
Mon Jan 25 19:47:00 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Check enum type on overload resolution
Mon Jan 25 19:46:41 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* single-float conversion
Mon Jan 25 19:41:22 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Add :arg3 for make-instance SMOKE-CLASS.
Sat Jan 23 20:45:41 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* class & type size (and some more exports)
Sun Jan 17 22:04:08 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* 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 <tobias@rautenkranz.ch>
* Fix overload resolution when a lisp smoke module is not loaded.
Sun Jan 10 18:30:48 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Auto-recompile when the smoke module has changed.
Sun Jan 10 09:49:36 CET 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Support modular smoke & cleanup.
Sun Dec 13 13:43:58 CET 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Support ASDF instead of Mudballs.
Sun Dec 13 11:17:08 CET 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Update to the new Smoke ABI (v.3)
Fri Nov 6 20:27:56 CET 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Explicitly use old ABI (pre r1045709)
Wed Sep 9 21:25:37 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Template types are no longer t_class.
Wed Sep 9 15:22:32 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* 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 <tobias@rautenkranz.ch>
* 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 <tobias@rautenkranz.ch>
* Fix overload resolution using types and test caching the overload resolution.
Sun Aug 30 16:12:44 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Allow deriving from multiple C++ classes.
Sun Aug 30 15:51:40 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* 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 <tobias@rautenkranz.ch>
* 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 <tobias@rautenkranz.ch>
* Cleanup C++ to Lisp translation
Fri Jul 24 15:32:23 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix conversion sequence from QByteArray to const char*.
Thu Jul 23 00:26:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* 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 <tobias@rautenkranz.ch>
* Speedup overload resolution and some other stuff for faster C++ method calling.
Wed Jul 8 16:56:52 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* SBCL: compile time overload resolution
Fri Jul 3 11:50:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix methods and method-maps bounds.
Thu Jul 2 23:51:50 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Promption real to double-float
Thu Jul 2 23:51:14 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix infinite loop when showing candidate functions.
Thu Jul 2 21:08:40 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix undefine init_smoke* C function & cleanup finalizers when a image is saved.
Wed Jul 1 12:54:01 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Spellcheck
Wed Jul 1 00:47:39 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix for Clozure CL
Tue Jun 30 22:54:49 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* CLISP workaround finalizer for objects in weak hash table crash.
Mon Jun 22 14:18:08 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* 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 <tobias@rautenkranz.ch>
* Load Smoke libraries at compile time.
Thu Jun 11 20:45:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* futile CLISP fixes
Thu Jun 11 16:35:40 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Modules can specify the package to place the classes, static methods and constants in.
Wed Jun 10 14:01:10 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* No need for a synchronized hash table when threads are not supported.
Wed Jun 10 13:55:55 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix ownership transfer for non cxx:class objects.
Mon Jun 8 11:20:54 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Make unreadable cycles garbage collectable.
Wed Jun 3 23:55:26 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Added restarts to method dispatch callback.
Mon Jun 1 00:22:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* fix define-takes-ownership return value
Sun May 31 19:41:26 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Ownership for return values on the stack
Sat May 30 14:12:25 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* soversion for wrappers
Thu May 28 15:43:36 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix CCL and allow ASDF
Wed May 27 19:47:28 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Condition NO-APPLICABLE-CXX-METHOD
Wed May 27 19:22:08 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix error when printing a SMOKE-OBJECT with an unbound pointer slot.
Wed May 27 14:20:30 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix some warnings
Tue May 26 11:54:47 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Cleanup Lisp -> C++ conversion
Mon May 25 20:39:33 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* speed up get-struct-slot-value & cleanup
Sun May 24 23:28:44 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Allow passing a raw pointer for an argument of type class
Sun May 24 13:30:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* cleanup finalization stuff
Fri May 22 16:57:59 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Use synchronized object-map
Tue May 19 15:59:22 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Clozure CL save image
Tue May 19 13:09:12 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix loading with Clozure CL
Thu May 14 14:07:00 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Dump Lisp image & make bundle with C wrapper libraries.
Tue May 12 15:54:46 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Support Clozure CL
Mon May 11 22:18:23 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Make &rest lambda list for static methods only when necessary.
Mon May 11 19:55:42 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Support (setf (getter-method) value) for C++ set* methods.
Mon May 11 16:11:35 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Export Lisp -> C++ API.
Mon May 11 15:35:40 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix enum to int promotion.
Mon May 11 14:30:33 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* cleanup: use package alexandria.
Mon May 11 14:21:24 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* cleanup: rename type= to smoke-type=.
Mon May 11 14:05:00 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Visibility for C wrappers
Mon May 11 14:02:40 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Cleanup: unpush does not need second argument.
Mon May 11 13:07:39 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Prepare for overload resolution at compile time
Fri Apr 17 17:26:55 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Experimental C++ style overload resolution.
Tue Apr 14 16:23:24 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* License
diff -rN -u old-smoke/CMakeLists.txt new-smoke/CMakeLists.txt
--- old-smoke/CMakeLists.txt 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/CMakeLists.txt 2014-10-30 08:15:09.000000000 +0100
@@ -3,6 +3,5 @@
project(smoke)
add_subdirectory(src)
-add_subdirectory(examples)
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-30 08:15:09.000000000 +0100
@@ -0,0 +1,676 @@
+
+ GNU GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ 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.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ 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 <http://www.gnu.org/licenses/>.
+
+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:
+
+ <program> Copyright (C) <year> <name of author>
+ 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
+<http://www.gnu.org/licenses/>.
+
+ 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
+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+
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-30 08:15:09.000000000 +0100
@@ -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/TODO new-smoke/TODO
--- old-smoke/TODO 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/TODO 1970-01-01 01:00:00.000000000 +0100
@@ -1,22 +0,0 @@
-Methods:
- * C++ overload resolution & argument promotion
- => no more writing (make-instance 'qt:byte-array :args ("foo"))
- * Test for null pointer in this and for references
- * default arguments
- * fetch name of arguments
-
-* const correctness
-
-* keyword arguments for make-instance
-
-* QApplication and KCmdLineArgs.init call exit() on e.g. "--help"
-
-Testsuite:
- * Fix segfaults when lots of qt:applictions are created & deleted
- * Test condition & restarts
-
-finalization:
- * get rid of owned-p
- * use QObject::deleteLater ?
-
-* Exceptions
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-30 08:15:09.000000000 +0100
@@ -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/examples/CMakeLists.txt new-smoke/examples/CMakeLists.txt
--- old-smoke/examples/CMakeLists.txt 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/examples/CMakeLists.txt 1970-01-01 01:00:00.000000000 +0100
@@ -1,16 +0,0 @@
-
-find_package(Qt4)
-set(QT_DONT_USE_QTGUI true)
-include(${QT_USE_FILE})
-
-find_library(SMOKE_KDE_LIBRARY smokekde)
-include(FindPackageHandleStandardArgs)
-find_package_handle_standard_args(smokekde DEFAULT_MSG SMOKE_KDE_LIBRARY)
-
-## kde-hello-world
-if(SMOKE_KDE_LIBRARY)
- include_directories("${CMAKE_CURRENT_SOURCE_DIR}/../src/smoke-c/")
-
- add_executable(kde-hello-world kde-hello-world.cpp ../src/smoke-c/csmokebinding.cpp)
- target_link_libraries(kde-hello-world ${SMOKE_KDE_LIBRARY})
-endif(SMOKE_KDE_LIBRARY)
diff -rN -u old-smoke/examples/kde-hello-world.cpp new-smoke/examples/kde-hello-world.cpp
--- old-smoke/examples/kde-hello-world.cpp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/examples/kde-hello-world.cpp 1970-01-01 01:00:00.000000000 +0100
@@ -1,164 +0,0 @@
-/*
- * Copyright 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
- *
- * Permission is hereby granted, free of charge, to any person
- * obtaining a copy of this software and associated documentation
- * files (the "Software"), to deal in the Software without
- * restriction, including without limitation the rights to use,
- * copy, modify, merge, publish, distribute, sublicense, and/or sell
- * copies of the Software, and to permit persons to whom the
- * Software is furnished to do so, subject to the following
- * conditions:
- *
- * The above copyright notice and this permission notice shall be
- * included in all copies or substantial portions of the Software.
- *
- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
- * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
- * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
- * HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
- * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
- * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
- * OTHER DEALINGS IN THE SOFTWARE.
- */
-
-/**
- * Hello world example using libsmoke-c.
- * Display an KDE Window. */
-
-#include <smoke/qt_smoke.h>
-#include <smoke/kde_smoke.h>
-
-#include "smoke-c.cpp"
-
-#include <iostream>
-
-using namespace std;
-using namespace cl_smoke;
-
-static void
-destructed(Binding* binding, Smoke::Index class_id,
- void* object)
-{
- cout << "destructed: " << binding->className(class_id) << endl;
-}
-
-/** No method dispatch in this example. */
-static int
-dispatch(Binding* binding, Smoke::Index method,
- void* object, Smoke::Stack args, int abstract)
-{
- return false;
-}
-
-int
-main(int argc, char** argv)
-{
- init_kde_Smoke(); // calls also init_qt_Smoke();
- smoke_binding kde = smoke_init(kde_Smoke, reinterpret_cast<void*>(&destructed),
- reinterpret_cast<void*>(&dispatch));
- smoke_binding qt = smoke_init(qt_Smoke, reinterpret_cast<void*>(&destructed),
- reinterpret_cast<void*>(&dispatch));
-
- Smoke::StackItem stack[5];
- Smoke::ModuleIndex m;
- Smoke::ModuleIndex c;
-
- // bytearray = new QByteArray("foo");
- {
- char str[] = "foo";
-
- smoke_find_class(&c, qt_Smoke, "QByteArray");
- smoke_find_method(&m, qt_Smoke, c.index, "QByteArray$");
-
- stack[1].s_class = str;
-
- smoke_call_method(qt_Smoke, m.index, NULL, stack);
- }
- void* bytearray = stack[0].s_class;
-
-
- // l10n = ki18n(bar);
- {
- char str[] = "hello world";
- smoke_find_class(&c, kde_Smoke, "QGlobalSpace");
- smoke_find_method(&m, kde_Smoke, c.index, "ki18n$");
-
- stack[1].s_class = str;
-
- smoke_call_method(kde_Smoke, m.index, NULL, stack);
- }
- void* l10n = stack[0].s_class;
-
- // about = KAboutData(bytearray, bytearray, l10n, bytearray);
- {
- smoke_find_class(&c, kde_Smoke, "KAboutData");
- smoke_find_method(&m, kde_Smoke, c.index, "KAboutData####");
-
- stack[1].s_class = bytearray;
- stack[2].s_class = bytearray;
- stack[3].s_class = l10n;
- stack[4].s_class = bytearray;
-
- smoke_call_method(kde_Smoke, m.index, NULL, stack);
- }
- void* about = stack[0].s_class;
-
-
- // KCmdLineArgs::init(argc, argv, about);
- {
- smoke_find_class(&c, kde_Smoke, "KCmdLineArgs");
- smoke_find_method(&m, kde_Smoke, c.index, "init$?#");
-
- stack[1].s_int = argc;
- stack[2].s_class = argv;
- stack[3].s_class = about;
-
- smoke_call_method(kde_Smoke, m.index, NULL, stack);
- }
-
- // app = new KApplication();
- void* app;
- {
- smoke_find_class(&c, kde_Smoke, "KApplication");
- smoke_find_method(&m, kde_Smoke, c.index, "KApplication");
-
- smoke_call_method(kde_Smoke, m.index, NULL, stack);
- app = stack[0].s_class;
-
- smoke_set_binding(c.smoke, kde, c.index, app);
- }
-
- {
- smoke_find_class(&c, kde_Smoke, "KGlobalSettings");
- smoke_find_method(&m, kde_Smoke, c.index, "Disable");
- smoke_call_method(kde_Smoke, m.index, NULL, stack);
- }
-
- // widget = new KXmlGuiWindow();
- // widget->setupGUI();
- // widget->show();
- // return app->exec();
- void* widget;
- {
- smoke_find_class(&c, kde_Smoke, "KXmlGuiWindow");
- smoke_find_method(&m, kde_Smoke, c.index, "KXmlGuiWindow");
-
- smoke_call_method(m.smoke, m.index, NULL, stack);
- widget = stack[0].s_class;
- smoke_set_binding(c.smoke, kde, c.index, widget);
-
- smoke_find_method(&m, c.smoke, c.index, "setupGUI");
- smoke_call_method(m.smoke, m.index, widget, stack);
-
- smoke_find_method(&m, c.smoke, c.index, "show");
- smoke_call_method(m.smoke, m.index, widget, stack);
-
- smoke_find_class(&c, kde_Smoke, "KApplication");
- smoke_find_method(&m, c.smoke, c.index, "exec");
- smoke_call_method(m.smoke, m.index, NULL, stack);
-
- return stack[0].s_int;
- }
-}
diff -rN -u old-smoke/smoke.mbd new-smoke/smoke.mbd
--- old-smoke/smoke.mbd 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/smoke.mbd 1970-01-01 01:00:00.000000000 +0100
@@ -1,70 +0,0 @@
-;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
-
-;;; Allow this file to compile even when sysdef.cmake is not loaded.
-;;; You can not add a (MB:LOAD :SYSDEF.CMAKE) on top since when Mudballs
-;;; loads this file it might not know yet about :SYSDEF.CMAKE.
-(defpackage :sysdef.cmake
- (:use :cl :sysdef)
- (:export :cmake-file :cmake-library))
-(in-package :sysdef.cmake)
-
-(defclass sysdef.cmake:cmake-file (source-file)
- ()
- (:default-initargs :type "txt"))
-
-(defclass sysdef.cmake:cmake-library (component)
- ())
-;;; end SYDDEF.CMAKE
-
-(in-package :sysdef-user)
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (use-package :sysdef.cmake))
-
-(define-system :smoke ()
- (:version 0 0 1)
- (:documentation "Smoke bindings. Provides the base functionality to
-implement bindings using the various Smoke modules.")
- (:author "Tobias Rautenkranz")
- (:components
- ("CMakeLists" cmake-file)
- (:src module
- (:needs "CMakeLists")
- (:components
- ("CMakeLists.txt" static-file)
- "package"
- ("translate" (:needs "package"))
- ("smoke" (:needs "smoke-c" "objects" "clos"))
- ("object-map" (:needs "objects"))
- ("class-map" (:needs "package"))
- ("bindings" (:needs "package"))
- ("cxx-method" (:needs "package"))
- ("clos" (:needs "smoke-c" "cxx-method" "objects" "object-map" "class-map" "bindings"))
- ("method" (:needs "clos"))
- (:objects module
- (:needs "smoke-c" "utils")
- (:serial t)
- (:components "object" "enum" "method" "class"
- "type" "instance" "stack"))
- (:smoke-c module
- (:needs "package" "translate")
- (:components ("libsmoke-c" cmake-library)
- ("libsmoke-c-util" cmake-library)
-
- ;; Make release-action add this files
- ("CMakeLists.txt" static-file)
- ("csmokebinding.h" static-file)
- ("csmokebinding.cpp" static-file)
- ("smoke-c.cpp" static-file)
-
- ("smoke-c" (:needs "libsmoke-c"
- "libsmoke-c-util"))
- ("class" (:needs "smoke-c"))
- ("stack" (:needs "class"))
- ("method" (:needs "stack"))
- ("type" (:needs "method"))))
-
- (:utils module
- (:needs "package")
- (:components "get-value")))))
- (:needs :sysdef.cmake :cffi :closer-mop
- :trivial-garbage :bordeaux-threads))
diff -rN -u old-smoke/src/CMakeLists.txt new-smoke/src/CMakeLists.txt
--- old-smoke/src/CMakeLists.txt 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/CMakeLists.txt 2014-10-30 08:15:09.000000000 +0100
@@ -1 +1 @@
-add_subdirectory(smoke-c)
+add_subdirectory(libsmoke)
diff -rN -u old-smoke/src/bindings.lisp new-smoke/src/bindings.lisp
--- old-smoke/src/bindings.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/bindings.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -1,22 +1,54 @@
(in-package :smoke)
-(defvar *bindings* (make-hash-table))
+(defstruct smoke-array
+ "A C array."
+ (pointer (null-pointer) :type foreign-pointer)
+ (length 0 :type (smoke-index 0)))
-;; FIXME is this lock needed? (The user may not have to
-;; load additional modules while threads are running.
-(defvar *bindings-lock* (make-lock "bindings-lock"))
-
-(defun binding (smoke)
- "Returns the Smoke binding for the Smoke module SMOKE."
- (with-lock-held (*bindings-lock*)
- (multiple-value-bind (value present-p)
- (gethash (pointer-address smoke) *bindings*)
- (assert (eql t present-p)
- ()
- "No binding for ~A." smoke)
- value)))
-
-(defun (setf binding) (binding smoke)
- (with-lock-held (*bindings-lock*)
- (setf (gethash (pointer-address smoke) *bindings*)
- binding)))
+(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 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/class-map.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -5,27 +5,32 @@
"Maps a Smoke module pointer - id pair to a class.")
;; FIXME disallow adding a class when threads are running or add a lock.
-(defmacro id-class-map (smoke)
- `(gethash (pointer-address ,smoke)
- *smoke-id-class-map*))
+(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)
- (unless (nth-value 1 (id-class-map smoke))
- (setf (id-class-map smoke)
- (make-hash-table))))
+ (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)))
+ (setf (gethash (id smoke-class) (id-class-map (smoke smoke-class)))
class))
-(defun find-smoke-class (class)
+(defun find-smoke-class (class &optional (error-p t))
"Returns the CLOS class for smoke-class CLASS."
- (let* ((class (real-class class))
- (ret (gethash (id class)
- (id-class-map (smoke class)))))
- (assert (not (null ret))
- ()
- "The class ~A was not found." (name 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.lisp new-smoke/src/clos.lisp
--- old-smoke/src/clos.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/clos.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -1,7 +1,5 @@
(in-package #:smoke)
-(declaim (optimize (speed 0) (debug 3)))
-
(declaim (inline lispify))
(defun lispify (name &optional (package nil))
"Returns the interned symbol for name in Lisp style."
@@ -20,8 +18,8 @@
,documentation
(declare (simple-string input)
(optimize (speed 3)))
- ;; At least on sbcl 1.0.25.debian CONCATENATE is faster
- ;; than VECTOR-PUSH-EXTEND
+ ;; At least on sbcl 1.0.25.debian CONCATENATE is faster than
+ ;; VECTOR-PUSH-EXTEND.
(let ((,output "")
(,index 0)
(,length (length input))
@@ -53,10 +51,10 @@
(define-string-transform lisp-to-cxx
"Converts LISP-STYLE to camelCase.
-Note that (LISP-TO-CXX (CXX-TO-LIST SOME-STRING)) will not neccessarily return
-a string equal to SMOME-STRING."
+Note that (LISP-TO-CXX (CXX-TO-LIST SOME-STRING)) will not necessarily return
+a string equal to SOME-STRING."
(default
- "Downcase, convert _ and dispatch."
+ "Down case, convert _ and dispatch."
(case char
(#\- (go-next camel-upcase))
(#\. (go-next namespace))
@@ -73,25 +71,27 @@
(go default)))
(define-string-transform cxx-to-lisp
- "Returns camelCase STRING in lisp-style."
+ "Returns camelCase STRING in lisp-style."
(begin
- "Strip leadind Q or K."
+ "Strip leading Q or K."
(case char
(#\K (go-next default))
(#\Q (go-next default))
(t (go default))))
(default
- "Upcase, convert _ and dispatch."
+ "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
- "Convert camelCase to lisp-style."
+ "C++ namespace separator"
(assert (eql #\: char))
(append-char #\.)
(go-next default))
@@ -105,134 +105,144 @@
(go default))))
-(defclass smoke-standard-object ()
- ((pointer :reader pointer :initarg :pointer
- :documentation "Pointer to the C++ object.")
- (owned-p :accessor owned-p :initarg :owned-p
- :initform t
- :documentation "T when the object is owned by Lisp and
-NIL when C++ is the owner.")
- (const-p :reader const-p :initarg :const-p
- :initform nil
- :documentation "T when the object is const and NIL otherwise."))
- (:documentation "The standard superclass for Smoke classes."))
-
(defmethod print-object ((object smoke-standard-object) stream)
- (print-unreadable-object (object stream :type t)
- (princ (pointer 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)
- ((enumerations :initform (make-hash-table)
- :initarg :enumerations
- :reader enumerations
- :documentation "The enumerations of the class.
-Maps the type-id of the enumeration to a hash-table that
-maps an enum value to a symbol."))
+ ()
(:documentation "A Smoke C++ class"))
-(defclass smoke-wrapper-class (smoke-standard-class)
- ())
-
-(defclass cxx:class (smoke-wrapper-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 closer-mop:validate-superclass ((class smoke-standard-class) (superclass standard-class))
- T)
-
-(defmethod closer-mop:validate-superclass ((class smoke-wrapper-class) (superclass smoke-standard-class))
- T)
+(defmethod reinitialize-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 &key direct-superclasses &allow-other-keys)
- (apply
- #'call-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 &key direct-superclasses &allow-other-keys)
- "Sets NIL superclass to SMOKE-STANDARD-OBJECT instead of the default STANDARD-OBJECT."
- (apply
- #'call-next-method class
- :direct-superclasses (or direct-superclasses
- (list (find-class 'smoke-standard-object)))
- args))
-
-(defmethod reinitialize-instance :around
- ((class smoke-wrapper-class)
- &rest args &key direct-superclasses &allow-other-keys)
- (assert (not (null direct-superclasses))
- (direct-superclasses)
- "No superclass suplied for class ~A" class)
- (let ((superclass (first direct-superclasses)))
- (assert (subtypep (class-of superclass) (find-class 'smoke-standard-class))
- ((first direct-superclasses))
- "The first superclass must be an subclass of an smoke class.")
- (apply
- #'call-next-method class
- :id (id superclass)
- :smoke (smoke superclass)
- :direct-superclasses direct-superclasses
- args)))
-(defmethod initialize-instance :around
- ((class smoke-wrapper-class)
- &rest args &key direct-superclasses &allow-other-keys)
+(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 suplied for class ~A" class)
- (let ((superclass (first direct-superclasses)))
- (assert (subtypep (class-of superclass) (find-class 'smoke-standard-class))
+ "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 must be an subclass of an smoke class.")
+ "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
- #'call-next-method class
+ next-method class
:id (id superclass)
:smoke (smoke superclass)
:direct-superclasses direct-superclasses
+ :direct-default-initargs direct-default-initargs
args)))
-(defun smoke-class-symbol (class)
- (if (external-p class)
- (class-name (find-smoke-class class))
- (lispify (name class))))
+(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 (smoke)
- "Construts a lisp class for each one in the Smoke module SMOKE."
- (declare (optimize (speed 3))
- (cffi:foreign-pointer smoke))
- (add-id-class-map smoke)
+(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)
- (add-id class
- (closer-mop:ensure-class (lispify (name class))
- :direct-superclasses
- (mapcar #'smoke-class-symbol
- (smoke-class-direct-superclasses class))
- :id (id class)
- :smoke (smoke class)
- :metaclass 'smoke-standard-class))
- (export (lispify (name class)))))
- smoke))
+ (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))
+ :type string
+ :documentation "The C++ name of the method."))
(:metaclass closer-mop:funcallable-standard-class)
- (:documentation "Smoke generic function"))
+ (:documentation "Smoke generic function."))
+(declaim (inline smoke-class-of))
(defun smoke-class-of (object)
- "Returns the class of OBJECT or OBJECT iff it alread is a class."
- (if (subtypep (class-of object) (find-class 'smoke-class))
+ "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)))
@@ -240,12 +250,9 @@
;;; ENSURE-METHOD is only called as needed.
(defmethod no-applicable-method ((gf smoke-gf) &rest args)
"Calls the smoke method."
- (declare (optimize (speed 3)))
- (let ((method (find-method-using-args (smoke-class-of (first args))
- (name gf) (rest args))))
- (if (static-p method)
- (s-call method (null-pointer) (rest args))
- (s-call method (cast (first args) (get-class method)) (rest args)))))
+ (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."
@@ -255,147 +262,308 @@
gf
`(lambda ,lambda-list
(declare (optimize (speed 3)))
- (let ((method (find-method-using-args (smoke-class-of ,(first lambda-list))
- (name ,(cxx-generic-function gf))
- (list ,@(rest lambda-list)))))
- (if (static-p method)
- (s-call method (null-pointer) (list ,@lambda-list))
- (s-call method (cast ,(first lambda-list) (get-class method))
- (list ,@(rest lambda-list))))))))))
+ (call-using-args ,(first lambda-list)
+ (name ,(cxx-generic-function gf))
+ (list ,@(rest lambda-list))))))))
(defcallback destructed :void
- ((binding :pointer)
- (id smoke-index)
- (object-pointer :pointer))
+ ((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
- (cancel-finalization 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)
- args
- (stack-to-args (cffi:inc-pointer stack
- (cffi:foreign-type-size 'smoke-stack-item))
+ (reverse args)
+ (stack-to-args (inc-pointer stack
+ (foreign-type-size 'smoke-stack-item))
(next arg)
- (append args (list
- (type-to-lisp (cffi:mem-ref stack 'smoke-stack-item)
- arg))))))
-
-(defgeneric set-returnvalue (stack value type))
-(defmethod set-returnvalue (stack (value smoke-standard-object) type)
- (assert (class-p type)
- (type)
- "The type ~A of the value ~A is not a class."
- (name type) value)
- (setf (foreign-slot-value stack 'smoke-stack-item 'class)
- (pointer value))
- (when (stack-p type) ;; Pass by value => smoke deletes the object.
- (cancel-finalization value) ;; Fixme mark object as invalid or copy it
- ;(remove-object (pointer value))
- (remove-if-exists (pointer value));;FIXME!
- (setf (slot-value value 'pointer) (null-pointer))))
-
-(defmethod set-returnvalue (stack (value integer) type)
- (setf (foreign-slot-value stack 'smoke-stack-item 'int)
- value))
-
-(defmethod set-returnvalue (stack (value (eql t)) type)
- (setf (foreign-slot-value stack 'smoke-stack-item 'bool)
- value))
+ (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)
+(defun put-returnvalue (stack value type object)
(unless (void-p type)
- (set-returnvalue stack value 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
- ((binding :pointer)
- (method smoke-index)
- (object :pointer)
+ ((method smoke-index)
+ (object-ptr :pointer)
(stack smoke-stack)
(abstract :boolean))
(declare (optimize (speed 3)))
- (let ((method (make-instance 'smoke-method
- :id method
- :smoke (smoke-get-smoke binding))))
- (let ((gf (symbol-function (lispify (name method) "CXX"))))
- (if (null (gf-methods gf))
- (progn
- (when abstract
- (error "Abstract method ~S called." (name method)))
- nil)
- (let ((object (get-object object)))
- (if object
- (progn
- (put-returnvalue stack
- (apply gf object
- (stack-to-args (cffi:inc-pointer stack (cffi:foreign-type-size 'smoke-stack-item))
- (get-first-argument method)))
- (return-type method))
- t)
- nil))))))
+ (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?
-(defun cast (object class)
- "Returns a pointer of type CLASS to the C++ object of OBJECT."
- (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 (class-of object)) (pointer object)
- ;(id (class-of object)) (id (real-class class))))
- (id (class-of object)) (class-id (smoke (class-of object))
- class)))
-
+(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 class) (pointer object)
+ (smoke-cast (smoke-module-pointer (smoke class)) (pointer object)
(id (class-of object)) (id (real-class class))))
-(defmethod convert-to-class (smoke-class (object smoke-standard-object))
- (cast object smoke-class))
-
-(defun make-smoke-constructor (class args)
- (find-method-using-args class
- (name class)
- args))
-
-(defun call-constructor (object args)
- (pointer-call (make-smoke-constructor (class-of object)
- args)
- (null-pointer)
- args))
+;; 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 &allow-other-keys)
+ &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)
- (setf (slot-value object 'pointer) (call-constructor object args))
- (set-binding object (binding (smoke (class-of object))))
- (setf (slot-value object 'owned-p) t)
+ (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)
- (let ((ret (make-instance class
- :owned-p (stack-p type)
- :pointer pointer)))
-; (when (stack-p type)
-; (add-object ret))
-; (set-binding ret (binding (smoke (class-of ret)))))
+ (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 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/cxx-method.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -1,5 +1,12 @@
(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
@@ -8,14 +15,7 @@
(:metaclass closer-mop:funcallable-standard-class)
(:documentation "Generic function of a specify argument count."))
-(defclass cxx-generic-function (standard-generic-function)
- ((gf-methods :initform nil
- :accessor gf-methods
- :type list
- :documentation "Generic functions for different argument counts."))
- (:metaclass closer-mop:funcallable-standard-class)
- (:documentation
- "A generic function that can be overloaded by argument count."))
+
(defun make-lambda (argument-count)
"Returns a lambda expression for ARGUMENT-COUNT arguments."
@@ -34,10 +34,14 @@
((integer 0) argument-count)
(values (or cxx-method-generic-function null)))
(find-if #'(lambda (gf)
- (= argument-count
- (argument-count 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."
@@ -45,9 +49,13 @@
((integer 0) argument-count))
(or (find-generic-function-by-argument-count cxx-generic-function
argument-count)
- (let ((gf (make-instance 'cxx-method-generic-function
- :cxx-generic-function cxx-generic-function
- :lambda-list (make-lambda 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)))
@@ -64,26 +72,28 @@
"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 contatin lambda list keywords." 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))))
+ (let ((generic-function (ensure-gf-by-argument-count
+ cxx-generic-function
+ (method-argument-count method))))
(add-method generic-function method)))
-(defun unpush-method (method cxx-generic-function)
+(defun unpush-method (method)
"Removes METHOD from its generic-function."
(let ((generic-function (closer-mop:method-generic-function method)))
(when generic-function
- (remove-method (closer-mop:method-generic-function) method))))
+ (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
@@ -93,7 +103,7 @@
(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 startup and the eval stuff is slower.
+ ;; 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))
@@ -106,8 +116,9 @@
(t (apply #'no-applicable-method ,cxx-generic-function args)))))))
+#+sbcl
(defmethod compute-applicable-methods ((gf cxx-generic-function) arguments)
- ;; -using-classes only cares abount the number of 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))
@@ -134,5 +145,23 @@
(update-method gf 'add-method method))
(defmethod remove-method ((gf cxx-generic-function) method)
- (unpush-method method gf)
+ (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-30 08:15:09.000000000 +0100
@@ -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-30 08:15:09.000000000 +0100
@@ -0,0 +1,50 @@
+#ifndef CL_SMOKE_H
+#define CL_SMOKE_H
+
+#include <smoke.h>
+
+#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*>(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-30 08:15:09.000000000 +0100
@@ -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-30 08:15:09.000000000 +0100
@@ -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-30 08:15:09.000000000 +0100
@@ -0,0 +1,240 @@
+#include "cl_smoke.h"
+#include "smokebinding.h"
+
+#include <smoke.h>
+#include <QtGlobal>
+
+/** @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<NoDispatchBinding::destructed>(destruct));
+ else
+ return new Binding(reinterpret_cast<NoDispatchBinding::destructed>(destruct),
+ reinterpret_cast<Binding::dispatch_method>(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<SmokeBinding*>(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-30 08:15:09.000000000 +0100
@@ -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-30 08:15:09.000000000 +0100
@@ -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-30 08:15:09.000000000 +0100
@@ -0,0 +1,105 @@
+#include "smokebinding.h"
+
+#include <QtGlobal>
+#include <QDebug>
+
+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-30 08:15:09.000000000 +0100
@@ -0,0 +1,50 @@
+#ifndef SMOKEBINDING_H
+#define SMOKEBINDING_H
+
+#include <smoke.h>
+
+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-30 08:15:09.000000000 +0100
@@ -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-30 08:15:09.000000000 +0100
@@ -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/marshall.lisp new-smoke/src/marshall.lisp
--- old-smoke/src/marshall.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/marshall.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,152 +0,0 @@
-(in-package :smoke)
-
-(declaim (optimize (debug 3)))
-
-(defmacro average (&rest args)
- `(floor (+ ,@args) ,(length args)))
-
-
-(defun binary-find (lower upper < =)
- (let ((mid (average lower upper)))
- (if (= mid lower)
- nil
- (if (funcall = mid)
- mid
- (if (funcall < mid)
- (binary-find lower mid < =)
- (binary-find mid upper < =))))))
-
-(defun serach-method (smoke name)
- (binary-find 1 (smoke-method-name-size smoke)
- #'(lambda (index)
- (string< name
- (smoke-get-method-name smoke index)))
- #'(lambda (index)
- (string= name
- (smoke-get-method-name smoke index)))))
-
-(defun find-last (lower upper =)
- (if (or (>= lower upper)
- (not (funcall = (1+ lower))))
- lower
- (find-last (1+ lower) upper =)))
-
-
-(defun find-methods (smoke name)
- (let* ((index (serach-method smoke name))
- (= #'(lambda (index)
- (string= name
- (smoke-get-method-name smoke index)
- :end2 (length name))))
- (upper (find-last index (smoke-method-name-size smoke) =))
- (methods nil))
- (loop for i from index to upper do
- (push (smoke-get-method-name smoke i)
- methods))
- methods))
-
-
-
-;(defmethod exact-match ((object singl-float) type))
-(defun type-equal (type type-name)
- (equal (name type) type-name))
-
-(defun exact-match (object type)
- (format t "~A ~A~%" object (name type))
- (ctypecase object
- (smoke-standard-object
- (and (class-p type)
- (derived-p (class-of object)
- (get-class type))))
- (double-float (type-equal type "double"))
- (single-float (type-equal type "float"))
- (integer (type-equal type "int"))
- (string (or (type-equal type "const char*")
- (type-equal type "const QString&")))
- (character (type-equal type "char"))))
-
-(defun exact-match-p (arguments types)
- (if (or (null arguments) (null types))
- (and (null arguments)
- (null types))
- (if (not (exact-match (first arguments)
- (first types)))
- nil
- (exact-match-p (rest arguments)
- (rest types)))))
-
-(defun promotion-match (object type)
- (ctypecase object
- (character (type-equal type "int"))
- (float (type-equal type "double"))
- (boolean (type-equal type "int"))))
-
-(defun standard-conversion-match (object type)
- (ctypecase object
- (number (or (type-equal type "short")
- (type-equal type "int")
- (type-equal type "long")))))
-
-(defun constructor-match (object type)
- (if (class-p type)
- (let ((constructor (make-smoke-constructor (get-class type)
- (mung-arg object))))
- (exact-match object (get-first-argument constructor)))
- nil))
-
-(defun find-ambiguous-method (predicate method)
- (let ((index (- (id method))))
- (loop as i = (smoke-ambiguous-method (smoke method)
- index)
- while (> i 0) do
- (incf index)
- (let ((ambiguous-method (make-instance 'smoke-method
- :smoke (smoke method)
- :id i)))
- (when (funcall predicate ambiguous-method)
- (return ambiguous-method))))))
-
-(defun find-method-using-args (class name arguments)
- (with-foreign-object (m 'smoke-module-index)
- (smoke-find-method m (smoke class) (id class)
- (concatenate 'string name
- (munged-args arguments)))
- (let ((method (make-instance 'smoke-method
- :smoke (foreign-slot-value m
- 'smoke-module-index
- 'smoke)
- :id (foreign-slot-value m
- 'smoke-module-index
- 'index))))
- (when (< (id method) 0)
- (setf method
- (find-ambiguous-method #'(lambda (method)
- (exact-match-p arguments (arguments method)))
- method))
- (assert (not (null method)) (method)
- "No method ~A::~A for the arguments ~A"
- (name class) name arguments))
- method)))
-
-
-(defgeneric get-convert-function (to from))
-(defmethod get-convert-function ((to eql 'int) (from eql 'char)))
-(defmethod get-convert-function ((to cxx::int) (from string)))
-
-(get-convert-function 'int 'char)
-
-;'const int 'char:
-(get-convert-function 'int 'char)
-&& (convert-const-p 'char)
-
-;'int 'const char:
-(get-convert-function 'int 'char)
-&& (not (const-p 'char))
-
-
-(defclass int ()
- ((const-p)))
-
-(defun get-convert-function (to from))
-
-
diff -rN -u old-smoke/src/method.lisp new-smoke/src/method.lisp
--- old-smoke/src/method.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/method.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,142 +0,0 @@
-(in-package :smoke)
-
-(declaim (optimize (debug 3)))
-
-(defun enum-class-symbol (enum-type)
- (let ((class-name (name (get-class enum-type))))
- (if (null class-name)
- 'global-enum-class
- (lispify class-name))))
-
-(defun constant-definition (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 (string= (name (get-class method))
- "Qt")
- (lispify (concatenate 'string "+" (name method)
- "+"))
- (lispify (concatenate 'string
- (name (get-class method))
- ".+"
- (name method) "+")))))
- (values
- ; `(defconstant ,symbol
- ; ,(enum-call method))
- `(alexandria:define-constant ,symbol
- (make-instance 'enum
- :value ,(enum-call method)
- :type (make-instance 'smoke-type
- :id ,(id (return-type method))
- :smoke ,smoke))
- :test #'enum=)
- `(export (quote ,symbol)))))
-
-(defun static-method-symbol (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)))))
-
-(defun static-method-definition (method smoke)
- "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 (lispify (concatenate 'string
- (if (string= (name class)
- "QGlobalSpace")
- nil
- (concatenate 'string
- (name class)
- "."))
- (name method)))))
- (values
- `(defun ,name (&rest args)
- (let ((method (find-method-using-args (make-instance 'smoke-class
- :id ,(id class)
- :smoke ,smoke)
- ,method-name args)))
- (s-call method (null-pointer) args)))
- `(export (quote ,name)))))
-
-(defun hash-table-key-values (hash-table)
- "Returns a list containing all key-value pairs as CONS of HASH-TABLE."
- (let ((list))
- (maphash #'(lambda (key value)
- (push (cons key value) list))
- hash-table)
- list))
-
-(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)))
-
-(defmacro check-recompile (smoke)
- "Raises an error when the fasl of the DEFINE-METHOS was not compiled against
-the current smoke module."
- `(eval-when (:load-toplevel :execute)
- (unless (= (smoke-methods-size ,smoke)
- ,(smoke-methods-size (eval smoke)))
- (error "The smoke module ~A changed, you need to recompile the lisp file."
- (smoke-get-module-name ,smoke)))))
-
-
-(defmacro define-methods (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
-;;; mulitiple definiton of a function with the same name.
- (let ((generics (make-hash-table))
- (constants)
- (functions)
- (function-symbols (make-hash-table))
- (exports))
- (map-methods
- #'(lambda (method)
- (when (and (enum-p method)
- ;; FIXME workaround for
- ;; http://lists.kde.org/?l=kde-bindings&m=123464781307375
- (not (string= (name (get-class method))
- "KGlobalSettings")))
- (multiple-value-bind (def export) (constant-definition 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 funciton
- (setf (gethash (lispify (name method) "CXX") generics)
- (name method))
- (when (static-p method)
- (let ((function-symbol (static-method-symbol method)))
- (unless (nth-value 1 (gethash function-symbol function-symbols))
- (setf (gethash function-symbol function-symbols) t)
- (multiple-value-bind (def export) (static-method-definition method smoke)
- (push def functions)
- (push export exports)))))))
- (eval smoke))
- `(progn (check-recompile ,smoke)
- ,@functions
- (eval-when (:load-toplevel :execute)
- (ensure-generic-methods ',(hash-table-key-values generics))
- (make-smoke-classes ,smoke))
- ,@constants
- ,@exports)))
-
diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp
--- old-smoke/src/object-map.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/object-map.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -1,30 +1,89 @@
(in-package :smoke)
-(defvar *object-map*
- #-cmucl (make-weak-hash-table :weakness :value)
- #+cmucl (make-hash-table :weak-p :value)
-
- "Maps a lisp object to Smoke C++ object.")
-
-;; FIXME This probably does not scale well. A per thread object-map
-;; or at least a read-write lock should be used.
-(defvar *object-map-mutex* (make-lock "object-map lock"))
+#+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)
- (with-lock-held (*object-map-mutex*)
- (gethash (pointer-address pointer) *object-map*)))
+ (gethash (pointer-address pointer) *object-map*))
+(declaim (inline (setf get-object)))
(defun (setf get-object) (value pointer)
- (with-lock-held (*object-map-mutex*)
- (setf (gethash (pointer-address pointer) *object-map*)
- value)))
-
+ (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."
- (with-lock-held (*object-map-mutex*)
- (nth-value 1 (gethash (pointer-address pointer) *object-map*))))
+ (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."))
@@ -33,37 +92,29 @@
(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)
- (condition (condition)
- (format *debug-io* "error finalize ~A ~A~%" (name class)
- condition))))))
-
+ (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)
- (assert (not (has-pointer-p (pointer object)))
- ()
- "There exists already a object ~A for the pointer of ~A."
- (get-object (pointer object)) object)
- (when (owned-p object)
- (let ((finalizer (make-finalize object)))
- (finalize object finalizer)))
+ "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))
-
-(defun remove-if-exists (pointer)
- (with-lock-held (*object-map-mutex*)
- (remhash (pointer-address pointer) *object-map*)))
-
-(defun remove-object (pointer)
- (assert (has-pointer-p pointer)
- (pointer)
- "No object to remove for pointer ~A." pointer)
- (with-lock-held (*object-map-mutex*)
- (remhash (pointer-address pointer) *object-map*)))
-
-(defun print-garbage ()
- (with-lock-held (*object-map-mutex*)
- (maphash #'(lambda (pointer object)
- (format t "~A of type: ~S~%"
- (make-pointer pointer)
- (class-name (class-of object))))
- *object-map*)))
diff -rN -u old-smoke/src/objects/class.lisp new-smoke/src/objects/class.lisp
--- old-smoke/src/objects/class.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/objects/class.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -1,82 +1,118 @@
(in-package #:smoke)
-;;;
-;;; find-class
-;;; ensure-class
-;;; make-instance
-;;; class-name
-;;; class-slots
-;;; class-direct-subclasses
-;;; class-direct-superclasses
-;;; class-of
-;;; subclassp / subtypep
+(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))
-(defclass smoke-class (smoke-symbol)
- ()
- (:documentation "A class"))
+(defmethod name ((class smoke-class))
+ (class-slot-value class 'name))
-(defmethod get-struct-slot-value ((class smoke-class) slot-name)
- (foreign-slot-value (smoke-get-class (smoke class) (id class))
- 'smoke-class slot-name))
+(defun name-pointer (class)
+ (mem-ref (foreign-slot-pointer (smoke-class-pointer class)
+ 'smoke-class 'name)
+ :pointer))
-(defmethod name ((class smoke-class))
- (get-struct-slot-value class 'name))
+(defun class-size (smoke-class)
+ (class-slot-value smoke-class 'size))
(defun map-classes (function smoke)
- "Applys FUNCTION to the classes of SMOKE."
+ "Applies FUNCTION to the classes of SMOKE."
+ (declare (function function)
+ (optimize (speed 3)))
(let ((class (make-instance 'smoke-class
- :id 0
- :smoke smoke)))
- (loop for id from 1 to (1- (smoke-classes-size smoke)) do
- (setf (slot-value class 'id) id)
+ :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."
- (get-struct-slot-value class 'external))
-
-(defmethod get-flag ((class smoke-class) flag)
- (boole boole-and (get-struct-slot-value class 'flags)
- (foreign-enum-value 'smoke-class-flags flag)))
+ (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-flag class :constructor)))
+ (/= 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)
- ((smoke-name :initarg :smoke-name
- :initform nil
- :documentation "The name of the Smoke module"))
+ ()
(:report (lambda (condition stream)
- (format stream "No Smoke class named ~S in the Smoke module ~S."
- (cell-error-name condition)
- (slot-value condition 'smoke-name))))
+ (format stream "No Smoke class named ~S."
+ (cell-error-name condition))))
(:documentation "A undefined Smoke class"))
-;smoke-find-class
-(defun make-smoke-class (smoke name)
- "Returns the class named NAME of the smoke module SMOKE.
+(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 smoke name)
+ (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 :smoke-name (smoke-get-module-name 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))))
- (make-instance 'smoke-class
- :id (foreign-slot-value c 'smoke-module-index 'index)
- :smoke (foreign-slot-value c 'smoke-module-index 'smoke))))
+ (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 (smoke class) (name class))
+ (make-smoke-class (name class))
class))
(defun class-id (module class)
@@ -85,29 +121,33 @@
(id class)
(smoke-class-id module (name class))))
-;(defun smoke-subclassp (class base-class) TODO
(defun derived-p (class base-class)
"Returns T when CLASS is derived from BASE-CLASS and NIL when not."
- (values
- (derived-real-p (real-class class) (real-class base-class))
- T))
+ (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 class) (id class)
- (smoke base-class) (id 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 (get-struct-slot-value class 'parents)))
+ (smoke-add-superclass class nil (class-slot-value class 'parents)))
(defun smoke-add-superclass (class classes index)
- (let ((class-index (smoke-get-parent-index (smoke class) index)))
- (assert (< class-index (smoke-classes-size (smoke class))))
+ (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-instance 'smoke-class
- :id class-index
- :smoke (smoke class))))
- (1+ index)))))
+ (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 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/objects/enum.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -3,18 +3,25 @@
(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 thouse as enums, but C++ enums may have several symbols for
+;;; 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))
@@ -22,32 +29,41 @@
(defun check-enum-type (enum enum-type)
- (assert (type= (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 (type= (enum-type enum1)
- (enum-type 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)
- (let ((type (enum-type (eval (first (first 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 case))
+ (check-enum-type (eval (first-key (first case)))
type)))
`(progn
- ; (check-enum-type (enum-type ,keyform)
- ; (enum-type ,(first (first cases))))
+ ;; (check-enum-type (enum-type ,keyform)
+ ;; (enum-type ,(first (first cases))))
(,case (value ,keyform)
,@(loop for case in cases
- collect `(,(value (eval (first case)))
- ,@(rest case))))))
+ 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))
@@ -59,8 +75,11 @@
"Keyform returns a number; cases are enums."
`(case ,keyform
,@(loop for case in cases
- collect `(,(value (eval (first case)))
- ,@(rest case)))))
+ 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/method.lisp new-smoke/src/objects/method.lisp
--- old-smoke/src/objects/method.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/objects/method.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -1,16 +1,34 @@
(in-package #:smoke)
-(declaim (optimize (debug 3)))
-(defclass smoke-method (smoke-symbol)
- ()
- (:documentation "A C++ method"))
+(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 (null-pointer-p (smoke smoke-method))
- (call-next-method)
+ (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))
@@ -20,21 +38,32 @@
(slot-value condition 'class-name))))
(:documentation "A undefined Smoke method"))
-(defun valid-p (method)
- "Returns T when METHOD is valid and NIL otherwise."
- (/= 0 (id method)))
-
-(defun ambiguous-p (method)
- "Returns T when METHOD is ambiguous and NIL otherwise."
- (> 0 (id 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 (class name)
- "Returns the method called NAME of CLASS.
-Signals a undefined-method condition when no method was found."
+(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 class) (id class) name)
+ (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)))
@@ -44,146 +73,55 @@
:interactive read-new-value
(setf name new-name))))
(when (> 0 (foreign-slot-value m 'smoke-module-index 'index))
- (loop as i = (smoke-ambiguous-method (smoke class)
- (- (foreign-slot-value m 'smoke-module-index 'index)))
- while (> i 0)
+ (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-instance 'smoke-method :id i :smoke (smoke class))))
- (format t " ~A ~A~%" (name m) (signature m))))
- (error "The method ~S of ~S is ambigious" name (name class)));;TODO
- (make-instance 'smoke-method
- :id (foreign-slot-value m 'smoke-module-index 'index)
- :smoke (foreign-slot-value m 'smoke-module-index 'smoke))))
-
-(defun type-equal (type type-name)
- "Returns true when TYPE is of the type named TYPE-NAME and false otherwise."
- (equal (name type) type-name))
-
-(defun exact-match (object type)
- "Returns true when the type of OBJECT is exactly the same as TYPE and
-false otherwise."
- (ctypecase object
- (smoke-standard-object
- (and (class-p type)
- (derived-p (class-of object)
- (get-class type))))
- (double-float (type-equal type "double"))
- (single-float (type-equal type "float"))
- (integer (type-equal type "int"))
- ;; int is also enum
- ;; FIXME remove magic number 12
- ;;(= (type-id type) 12)))
- (string (or (type-equal type "const char*")
- (type-equal type "const QString&")))
- (enum (type= (enum-type object)
- type))
- (sequence (type-equal type "const QStringList&"))
- (character (type-equal type "char"))))
-
-(defun exact-match-p (arguments types)
- "Returns true when all the type of ARGUMENTS is the same as the
-corresponing type of TYPES and the length of the ARGUMENTS and TYPES list
-is equal."
- (if (or (null arguments) (null types))
- (and (null arguments)
- (null types))
- (if (not (exact-match (first arguments)
- (first types)))
- nil
- (exact-match-p (rest arguments)
- (rest types)))))
-
-(defun mung-arg (argument)
- "Returns the mung char for ARUGMENT."
- ;; FIXME void* is #\$ but void[] is #\?
- ;; FIXME Get rid of the mugging stuff and compute the applicable methods
- ;; including argument promotion
- (case argument
- ((t nil) #\$) ;; Booleans
- (otherwise
- (ctypecase argument
- (number #\$)
- (character #\$)
- (string #\$)
- (foreign-pointer #\?)
- (sequence #\?)
- (enum #\$)
- (smoke-standard-object #\#)))))
-
-(defun munged-args (arguments &optional (string nil))
- "Maps the type of every item of ARGUMENTS to a char;
-Returns the list of the chars."
- (if (null arguments)
- string
- (munged-args (rest arguments)
- (append string (list (mung-arg (first arguments)))))))
-
-(defun find-ambiguous-method (predicate method)
- "Returns a method of the ambiguous method METHOD such that
-PREDICATE is true. NIL is returned when no matching method is found."
- (assert (ambiguous-p method)
- (method)
- "The method is not ambiguous.")
- (let ((index (- (id method))))
- (loop as i = (smoke-ambiguous-method (smoke method)
- index)
- while (> i 0) do
- (incf index)
- (let ((ambiguous-method (make-instance 'smoke-method
- :smoke (smoke method)
- :id i)))
- (when (funcall predicate ambiguous-method)
- (return ambiguous-method))))))
-
-(defun find-method-using-args (class name arguments)
- "Returns the method of class CLASS with the name NAME
-for the arguments ARGUMENTS."
- (with-foreign-object (m 'smoke-module-index)
- (smoke-find-method m (smoke class) (id class)
- (concatenate 'string name
- (munged-args arguments)))
- (let ((method (make-instance 'smoke-method
- :smoke (foreign-slot-value m
- 'smoke-module-index
- 'smoke)
- :id (foreign-slot-value m
- 'smoke-module-index
- 'index))))
- (assert (valid-p method)
- (method)
- "No method ~A::~A for the arguments ~A" (name class) name arguments)
- (when (ambiguous-p method)
- (setf method
- (find-ambiguous-method #'(lambda (method)
- (exact-match-p arguments (arguments method)))
- method))
- (assert (not (null method)) (method)
- "No method ~A::~A for the arguments ~A"
- (name class) name arguments))
- method)))
-
+ (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)
- "Applys FUNCTION to the methods of SMOKE.
+ "Applies FUNCTION to the methods of SMOKE.
The method argument to function must not be modified."
(declare (function function)
- (cffi:foreign-pointer smoke)
(optimize (speed 3)))
- (let ((method (make-instance 'smoke-method
- :id 0
- :smoke smoke))
- (length (1- (the fixnum (smoke-methods-size smoke)))))
- (loop for id from 1 to length do
- (setf (slot-value method 'id) id)
+ (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))))
-(defmethod get-struct-slot-value ((method smoke-method) slot-name)
- (foreign-slot-value (smoke-get-method (smoke method) (id 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))
- (smoke-get-method-name (smoke method)
- (get-struct-slot-value method 'name)))
+ (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."
@@ -199,14 +137,15 @@
"public"))
(defun modifiers (method)
- (format nil "~A~:[~; static~]" (access method)
- (static-p 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 (get-struct-slot-value method 'return-type)
- :smoke (smoke method)))
+ :id (method-slot-value method 'return-type)
+ :smoke (smoke-method-smoke method)))
(defun method-declaration (method)
(format nil "~A~:[ void~; ~1:*~A~] ~A::~A"
@@ -215,60 +154,87 @@
(name (get-class method))
(signature method)))
-(defgeneric get-flag (object flag)
- (:documentation "Returns the value for FLAG of OBJECT."))
-
-(defmethod get-flag ((method smoke-method) flag)
- (logand (get-struct-slot-value method 'flags)
+(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-flag method :constructor)))
+ (/= 0 (get-method-flag method :constructor)))
(defun destructor-p (method)
"Returns T when METHOD is a destructor; NIL otherwise."
- (/= 0 (get-flag method :destructor)))
+ (/= 0 (get-method-flag method :destructor)))
(defun static-p (method)
- "Retruns T when METHOD is static and NIL otherwise."
- (/= 0 (get-flag method :static)))
+ "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-flag method :protected)))
+ (/= 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-flag method :const)))
+ (/= 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 ambigious and NIL otherwise."
- (< 0 (id 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-flag method :enum)))
+ (/= 0 (get-method-flag method :enum)))
-(defmethod get-class ((method smoke-method))
- (make-instance 'smoke-class
- :id (get-struct-slot-value method 'class)
- :smoke (smoke method)))
+(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))
- (smoke-get-argument (smoke argument) (slot-value argument 'id)))
+ (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 (smoke-get-argument (smoke argument) (1+ (slot-value argument 'id)))))
+ (= 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."
@@ -285,20 +251,20 @@
(defun get-arguments-length (method)
"Returns the number of arguments for METHOD."
- (get-struct-slot-value method 'num-args))
+ (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 (get-struct-slot-value method 'arguments)
- :smoke (smoke method)))
+ :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 (+ (get-struct-slot-value method 'arguments) index)
- :smoke (smoke method)))
-
+ :id (+ (method-slot-value method 'arguments) index)
+ :smoke (smoke-method-smoke method)))
(defun build-argument-list (list argument)
(if (end-p argument)
@@ -309,4 +275,3 @@
(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 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/objects/object.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -1,22 +1,3 @@
(in-package #:smoke)
-
-(defclass smoke-symbol ()
- ((id :reader id :initarg :id
- :documentation "The objects index.")
- (smoke :reader smoke :initarg :smoke
- :initform (null-pointer)
- :documentation "Pointer to the Smoke module."))
- (:documentation "A method or class in a Smoke module."))
-
-(defmethod print-object ((smoke-symbol smoke-symbol) stream)
- (if (null-pointer-p (smoke smoke-symbol))
- (call-next-method)
- (print-unreadable-object (smoke-symbol stream :type t)
- (princ (name smoke-symbol) stream))))
-
-(defgeneric name (smoke-symbol)
- (:documentation "Returns the name of SMOKE-SYMBOL."))
-
-(defgeneric get-struct-slot-value (smoke-symbol slot-name)
- (:documentation "Returns the slot value of SLOT-NAME of
-the SMOKE-SYMBOLs struct."))
+
+(declaim (inline id))
diff -rN -u old-smoke/src/objects/stack.lisp new-smoke/src/objects/stack.lisp
--- old-smoke/src/objects/stack.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/objects/stack.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -1,40 +1,62 @@
(in-package #:smoke)
-(declaim (optimize (debug 3)))
-(defclass call-stack ()
- ((pointer :reader pointer :initarg :pointer
- :initform (null-pointer)
- :documentation "Pointer to the Smoke stack")
- (top :accessor top :initarg :top
- :initform (null-pointer)
- :documentation "Pointer to push the next argument to.")
- (cleanup-stack :accessor cleanup-stack
- :initform nil
- :documentation "Cleanup functions"))
- (:documentation "Contains the argument passed to a Smoke method."))
+(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 (top stack))
- (pointer-address (pointer stack)))
- (foreign-type-size 'smoke-stack-item)))
+ (/ (- (pointer-address (call-stack-top stack))
+ (pointer-address (call-stack-pointer stack)))
+ (foreign-type-size 'smoke-stack-item)))
(defun make-call-stack (smoke-stack)
- (make-instance 'call-stack
- :pointer smoke-stack
- :top (inc-pointer smoke-stack (foreign-type-size 'smoke-stack-item))))
+ (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 (top stack)
- 'smoke-stack-item type) value)
- (incf-pointer (top stack) (foreign-type-size 'smoke-stack-item)))
+ (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-cleanup (stack function)
- "Adds the cleanup function FUNCTION to STACK"
- (push function (cleanup-stack stack)))
-
-(defun push-stack2 (stack value type-id)
+(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))
@@ -49,43 +71,10 @@
(10 (push-stack stack value 'float))
(11 (push-stack stack value 'double))
(12 (push-stack stack (value value) 'enum-value))
- (13 (push-stack stack value 'class))))
-
-(defun push-smoke-stack (stack lisp-value smoke-type)
- (typecase smoke-type
- (smoke-type
- (cond
- ((class-p smoke-type)
- (push-stack2 stack
- (convert-to-class (get-class smoke-type) lisp-value)
- (type-id smoke-type)))
-; ((pointer-p smoke-type)
- (t
- (let ((cffi-type (get-type (name smoke-type))))
- (if (null cffi-type)
- (progn
- ; (assert (typep lisp-value 'foreign-pointer)
- ; (lisp-value)
- ; "The lisp-value ~S is not a foreign-pointer."
- ; lisp-value)
- (push-stack2 stack
- lisp-value
- (type-id smoke-type)))
- (multiple-value-bind (pointer args) (convert-to-foreign lisp-value
- cffi-type)
- (push-cleanup stack
- #'(lambda ()
- (free-converted-object pointer
- cffi-type
- args)))
- (push-stack2 stack
- pointer
- (type-id smoke-type))))))))
-; (t (push-stack2 stack lisp-value (type-id smoke-type)))))
- (t (push-lisp-object stack lisp-value smoke-type))))
-
-(defgeneric push-lisp-object (stack object class)
- (:documentation "Push the OBJECT on STACK."))
+ (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."
@@ -96,39 +85,36 @@
(unless (null args)
(assert (not (null arguments))
()
- "To many arguments suppliend (Arguments ~A)." args)
- (push-smoke-stack stack (first args) (first arguments))
- (set-smoke-stack stack (rest args) (rest 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)))
- (unwind-protect
- (progn
(set-smoke-stack ,stack ,args
,types)
- ,@body)
- (mapcar #'funcall (cleanup-stack ,stack)))))))
+ ,@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 (let ((cffi-type (get-type (name type))))
- (if (null cffi-type)
- (progn
- ;;(warn "Unknown translation from ~A to lisp." (name type))
- (foreign-slot-value stack-item 'smoke-stack-item 'voidp))
- (let* ((pointer (foreign-slot-value stack-item
- 'smoke-stack-item
- 'voidp))
- (value (convert-from-foreign pointer cffi-type)))
- (when (stack-p type)
- ;; FIXME free-translated-object is not intended for this;
- ;; param is NIL for now.
- (cffi:free-translated-object pointer cffi-type nil))
- value
- ))))
+ (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)))
@@ -141,37 +127,68 @@
(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)
+ :value (foreign-slot-value stack-item 'smoke-stack-item
+ 'enum-value)
:type type))))
(defgeneric instance-to-lisp (pointer class type)
- (:documentation "Returns a clos instance for POINTER."))
+ (declare (optimize (speed 3)))
+ (:documentation "Returns a CLOS instance for POINTER."))
(defun object-to-lisp (object type)
- (if (class-p type)
- (let ((class (get-class type)))
- (if (has-pointer-p object)
+ (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)
- (instance-to-lisp object (find-smoke-class class) type)))
- nil))
+ (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
+ (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))))
+ ((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 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/objects/type.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -1,78 +1,151 @@
(in-package #:smoke)
-(defclass smoke-type (smoke-symbol)
- ()
- (:documentation "A type"))
+(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 get-struct-slot-value ((type smoke-type) slot-name)
- (foreign-slot-value (smoke-get-type (smoke type) (id 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 name)
+ :id (smoke-find-type (smoke-module-pointer smoke) name)
:smoke smoke))
(defmethod name ((type smoke-type))
- (get-struct-slot-value type 'name))
+ (declare (optimize (speed 3)))
+ (type-slot-value type 'name))
-(defun type= (type1 type2)
- (and t ;(pointer-eq (smoke type1)
- ; (smoke type2))
- (= (id type1)
- (id type2))))
-
-(defmethod get-flag ((type smoke-type) flag)
- (boole boole-and (get-struct-slot-value type 'flags)
- (foreign-enum-value 'smoke-type-flags flag)))
+(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."
- (/= 0 (get-flag type :stack)))
+ (allocation-flag-p type :stack))
(defun reference-p (type)
"Returns T when TYPE is a reference ('type&'); NIL otherwise."
- (/= 0 (get-flag type :reference)))
+ (allocation-flag-p type :reference))
(defun pointer-p (type)
"Returns T when TYPE is a pointer ('type*'); NIL otherwise."
- (/= 0 (get-flag type :pointer)))
+ (allocation-flag-p type :pointer))
-(defmethod const-p ((type smoke-type))
- "Returns T when TYPE is const; NIL otherwise."
- (/= 0 (get-flag type :const)))
+(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)
- (/= -1 (get-struct-slot-value type 'class))))
+ (not (zerop (type-slot-value type 'class)))))
(defun type-id (type)
"Returns the ID of TYPE."
- (boole boole-and (get-struct-slot-value type 'flags)
- (foreign-enum-value 'smoke-type-flags :type-id)))
+ (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)."
- (null (name type)))
+ ;; 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 (/= -1 (get-struct-slot-value type 'class))
+ (assert (class-p type)
(type)
- "The type ~S is not a smoke class." (name type))
- (make-instance 'smoke-class
- :id (get-struct-slot-value type 'class)
- :smoke (smoke type)))
-
+ "The type ~S is not a smoke class." type)
+ (make-smoke-class-from-id (smoke type) (type-slot-value type 'class)))
-;; FIXME why macro?
-(defmacro smoke-type-p (type smoke type-name)
- (let ((t2 (smoke-find-type smoke type-name)))
- `(and (= (id ,type) ,(id t2))
- (pointer-eq (smoke ,type) ,(smoke t2)))))
+;; 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-30 08:15:09.000000000 +0100
@@ -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 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/package.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -3,6 +3,7 @@
(:export #:enum
#:enum=
#:enum-logand
+ #:enum-logior
#:value
#:enum-type
#:enum-case
@@ -10,25 +11,60 @@
#:enum-ecase))
(defpackage #:smoke
- (:use #:cl #:cffi #:trivial-garbage #:bordeaux-threads #:cxx-support)
- (:export #:init
+ (: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
- #:make-smoke-classes
-
- #:new-object
+ #: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
- #:smoke-call
- #:call
+ #:remove-object
- #:name
- #:id
- #:type=
+ #:eval-startup
- #:define-methods
+ #:get-smoke-variable-for-pointer
+ #:init
+ #:object-to-lisp
- #:cxx-bool
+ #:make-auto-pointer
+ #:make-cleanup-pointer
+
+ #:make-smoke-classes
+ #:make-smoke-type
+ #:no-applicable-cxx-method
+ #:smoke-call
+ #:upcast
- #:pointer))
+ #:smoke-standard-object
+ #:smoke-type
+ #:smoke-type=
+
+ #+sbcl #:save-bundle))
(defpackage #:cxx
(:use) ;; do not use #:cl
@@ -48,7 +84,3 @@
#:1-
#:aref))
-
-
-
-(in-package #:smoke)
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-30 08:15:09.000000000 +0100
@@ -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-c/CMakeLists.txt new-smoke/src/smoke-c/CMakeLists.txt
--- old-smoke/src/smoke-c/CMakeLists.txt 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/smoke-c/CMakeLists.txt 1970-01-01 01:00:00.000000000 +0100
@@ -1,11 +0,0 @@
-find_package(Qt4 REQUIRED)
-set(QT_DONT_USE_QTGUI true)
-include(${QT_USE_FILE})
-
-set(SMOKE_C_SOURCES smoke-c.cpp csmokebinding.cpp)
-add_library(smoke-c MODULE ${SMOKE_C_SOURCES})
-
-add_library(smoke-c-util MODULE smoke-c-util.cpp)
-
-install(TARGETS smoke-c smoke-c-util
- LIBRARY DESTINATION lib)
diff -rN -u old-smoke/src/smoke-c/class.lisp new-smoke/src/smoke-c/class.lisp
--- old-smoke/src/smoke-c/class.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/smoke-c/class.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,50 +0,0 @@
-(in-package #:smoke)
-
-(defcenum smoke-class-flags
- "Class properties"
- (:constructor #x01)
- (:copy-constructor #x02)
- (:virtual-destructor #x04)
- (: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))
-
-(defcfun smoke-find-class :void
- (m :pointer smoke-module-index)
- (smoke :pointer)
- (name :string))
-
-(defcfun smoke-class-id smoke-index
- (smoke :pointer)
- (name :string))
-
-(defcfun smoke-classes-size smoke-index
- (smoke :pointer))
-
-(defcfun smoke-get-class (:pointer smoke-class)
- (smoke :pointer)
- (class smoke-index))
-
-(defcfun smoke-get-parent-index smoke-index
- (smoke :pointer)
- (class smoke-index))
-
-(defcfun smoke-is-derived-from :boolean
- (smoke :pointer)
- (class smoke-index)
- (smoke-base :pointer)
- (base-class smoke-index))
-
-(defcfun smoke-cast :pointer
- (smoke :pointer)
- (object :pointer)
- (from smoke-index)
- (to smoke-index))
diff -rN -u old-smoke/src/smoke-c/csmokebinding.cpp new-smoke/src/smoke-c/csmokebinding.cpp
--- old-smoke/src/smoke-c/csmokebinding.cpp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/smoke-c/csmokebinding.cpp 1970-01-01 01:00:00.000000000 +0100
@@ -1,84 +0,0 @@
-#include "csmokebinding.h"
-
-#include <QtGlobal>
-
-namespace cl_smoke
-{
-
-/** @class Binding
- * @brief The Smoke binding.
- */
-
-
-/** @typedef Binding::destructed
- * Callback when a Smoke object is destructed.
- *
- * @param binding Smoke binding of the object
- * @param class_id class id
- * @param object the object
- */
-
-
-/** @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 smoke the Smoke module
- * @param destruct destruct callback
- * @param dispatch method dispatch callback
- */
-Binding::Binding(Smoke *smoke, destructed destruct,
- dispatch_method dispatch)
- : SmokeBinding(smoke),
- destruct(destruct),
- dispatch(dispatch)
-{
- Q_ASSERT(smoke);
- Q_ASSERT(destruct);
- Q_ASSERT(dispatch);
-}
-
-/** Invoked when a Smoke object is destructed. */
-void
-Binding::deleted(Smoke::Index classId, void *obj)
-{
- destruct(this, classId, obj);
-}
-
-/** Invoked whne a Smoke method gets called. */
-bool
-Binding::callMethod(Smoke::Index method, void* object,
- Smoke::Stack stack, bool abstract)
-{
- return dispatch(this, method, object, stack, abstract);
-}
-
-/**
- * @todo Returning a const char* would be better
- */
-char*
-Binding::className(Smoke::Index classId)
-{
- return const_cast<char*>(smoke->classes[classId].className);
-}
-
-/** Gets the Smoke instance associated with the binding.
- * @return a pointer to the Smoke instance
- */
-Smoke*
-Binding::get_smoke() const
-{
- return smoke;
-}
-
-} // namespace cl_smoke
diff -rN -u old-smoke/src/smoke-c/csmokebinding.h new-smoke/src/smoke-c/csmokebinding.h
--- old-smoke/src/smoke-c/csmokebinding.h 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/smoke-c/csmokebinding.h 1970-01-01 01:00:00.000000000 +0100
@@ -1,40 +0,0 @@
-#ifndef CSMOKEBINDING_H
-#define CSMOKEBINDING_H
-
-#include <smoke.h>
-
-namespace cl_smoke
-{
-
-class Binding : public SmokeBinding
-{
- public:
- typedef void (*destructed)(Binding* binding, Smoke::Index class_id,
- void* object);
-
- typedef int (*dispatch_method)(Binding* binding, Smoke::Index method,
- void* object, Smoke::Stack args, int abstract);
-
- Binding(Smoke *smoke, destructed destruct, dispatch_method dispatch);
-
- virtual void
- deleted(Smoke::Index classId, void *obj);
-
- virtual bool
- callMethod(Smoke::Index method, void* object,
- Smoke::Stack stack, bool abstract);
-
- virtual char*
- className(Smoke::Index classId);
-
- Smoke*
- get_smoke() const;
-
- private:
- const destructed destruct;
- const dispatch_method dispatch;
-};
-
-} // namespace cl_smoke
-
-#endif // CSMOKEBINDING_H
diff -rN -u old-smoke/src/smoke-c/method.lisp new-smoke/src/smoke-c/method.lisp
--- old-smoke/src/smoke-c/method.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/smoke-c/method.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,58 +0,0 @@
-(in-package #:smoke)
-
-(declaim (optimize (debug 3)))
-
-(defcenum smoke-method-flags
- "Method flags"
- (:static #x01)
- (:const #x02)
- (:copy-constructor #x04)
- (:internal #x08)
- (:enum #x10)
- (:constructor #x20)
- (:destructor #x40)
- (:protected #x80))
-
-(defcstruct smoke-method
- "Describe a method"
- (class smoke-index)
- (name smoke-index)
- (arguments smoke-index)
- (num-args :unsigned-char)
- (flags :unsigned-char)
- (return-type smoke-index)
- (method smoke-index))
-
-(defcfun smoke-find-method :void
- (m :pointer smoke-module-index)
- (smoke :pointer)
- (class smoke-index)
- (method :string))
-
-(defcfun smoke-methods-size smoke-index
- (smoke :pointer))
-
-(defcfun smoke-get-method (:pointer smoke-method)
- (smoke :pointer)
- (method smoke-index))
-
-(defcfun smoke-get-method-name :string
- (smoke :pointer)
- (method-index smoke-index))
-
-(defcfun smoke-method-name-size smoke-index
- (smoke :pointer))
-
-(defcfun smoke-call-method :string
- (smoke :pointer)
- (method smoke-index)
- (object :pointer)
- (stack smoke-stack))
-
-(defcfun smoke-get-argument smoke-index
- (smoke :pointer)
- (argument smoke-index))
-
-(defcfun smoke-ambiguous-method smoke-index
- (smoke :pointer)
- (ambiguous smoke-index))
diff -rN -u old-smoke/src/smoke-c/smoke-c-util.cpp new-smoke/src/smoke-c/smoke-c-util.cpp
--- old-smoke/src/smoke-c/smoke-c-util.cpp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/smoke-c/smoke-c-util.cpp 1970-01-01 01:00:00.000000000 +0100
@@ -1,18 +0,0 @@
-
-/** @file
- * \@brief Utility functions
- */
-
-extern "C" {
-
-/** Gets the size of the C++ bool type in bytes.
- *
- * @return the size of bool
- */
-int
-smoke_sizeof_bool()
-{
- return sizeof(bool);
-}
-
-} // extern "C"
diff -rN -u old-smoke/src/smoke-c/smoke-c.cpp new-smoke/src/smoke-c/smoke-c.cpp
--- old-smoke/src/smoke-c/smoke-c.cpp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/smoke-c/smoke-c.cpp 1970-01-01 01:00:00.000000000 +0100
@@ -1,430 +0,0 @@
-#include "csmokebinding.h"
-
-#include <smoke.h>
-
-#include <stdexcept>
-#include <QtGlobal>
-
-/** @file
- * \@brief C wrapper the Smoke bindings.
- *
- * \example examples/kde-hello-world.cpp
- * This KDE example creates a KXmlGuiWindow.
- * Note that C++ is only used to make the example shorter
- * (by allowing to directly include smoke-c.cpp), but it could also
- * be implemented in C using \c dlsym.
- *
- * \image html doc/images/kde-hello-world.png "Screenshot"
- * \image latex doc/images/kde-hello-world.png "Screenshot" width=5cm
- */
-
-
-/** @brief Common Lisp smoke binding namespace. */
-namespace cl_smoke
-{
-
-/** A Binding */
-typedef void* smoke_binding;
-
-/** Casts the void pointer smoke_binding to the Binding class.
- * @param smoke the smoke binding
- *
- * @return pointer to the Binding instance
- */
-static inline
-Binding*
-get_smoke_binding(smoke_binding binding)
-{
- return static_cast<Binding*>(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*>(smoke);
-}
-} // namespace cl_smoke
-
-using namespace cl_smoke;
-
-extern "C" {
-
-/** Returns the Smoke module of a Smoke binding.
- * @related cl_smoke::Binding
- * @param binding the Binding
- *
- * @return the Smoke module
- */
-void*
-smoke_get_smoke(smoke_binding binding)
-{
- return get_smoke_binding(binding)->get_smoke();
-}
-
-/** Creates a new Smoke binding.
- * The binding is allocated on the heap an can be freed with smoke_destruct().
- * @related cl_smoke::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.
- */
-smoke_binding
-smoke_init(void* smoke, void* destruct, void* dispatch)
-{
- return new Binding(static_cast<Smoke*>(smoke),
- reinterpret_cast<Binding::destructed>(destruct),
- reinterpret_cast<Binding::dispatch_method>(dispatch));
-}
-
-/** Deletes the smoke binding.
- * @related cl_smoke::Binding
- */
-void
-smoke_destruct(smoke_binding binding)
-{
- delete get_smoke_binding(binding)->get_smoke();
- delete get_smoke_binding(binding);
-}
-
-/** Gets a Smoke modules name.
- * @param smoke the Smoke module
- *
- * @return the module name
- */
-const char*
-smoke_get_module_name(void* smoke)
-{
- return get_smoke(smoke)->moduleName();
-}
-
-///////////////////////////
-/// Class
-///////////////////////////
-
-/** Finds a class.
- * @param c pointer to write the result to
- * @param smoke the smoke module
- * @param name the name of the class
- */
-void
-smoke_find_class(Smoke::ModuleIndex* c, void* smoke, const char* name)
-{
- *c = get_smoke(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
- */
-Smoke::Index
-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 the number of classes.
- *
- * @return the number of classes
- */
-Smoke::Index
-smoke_classes_size(void* smoke)
-{
- return get_smoke(smoke)->numClasses;
-}
-
-/** Sets the binding for an newly constructed instance.
- * @param smoke the Smoke module
- * @param binding the Smoke binding
- * @param class_index the index of the instances class
- * @param object pointer to the class instance.
- */
-void
-smoke_set_binding(void* smoke, smoke_binding binding, Smoke::Index class_index, void* object)
-{
- Q_ASSERT(object != NULL);
- Q_ASSERT(binding != NULL);
- Q_ASSERT(class_index > 0 && class_index <= smoke_classes_size(smoke));
-
- const Smoke::Class* klass = &get_smoke(smoke)->classes[class_index];
-
- Smoke::StackItem stack[2];
- stack[1].s_voidp = get_smoke_binding(binding);
-
- (*klass->classFn)(0, object, stack);
-}
-
-/** 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
- */
-const struct Smoke::Class*
-smoke_get_class(void* smoke, Smoke::Index class_index)
-{
- Q_ASSERT(class_index >= 0 && class_index <= smoke_classes_size(smoke));
- 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.
- */
-int
-smoke_is_derived_from(void* smoke, Smoke::Index class_index, void* smoke_base, Smoke::Index base_index)
-{
- Q_ASSERT(!smoke_get_class(smoke, class_index)->external);
- Q_ASSERT(!smoke_get_class(smoke_base, base_index)->external);
-
- return get_smoke(smoke)->isDerivedFrom(get_smoke(smoke), class_index,
- get_smoke(smoke_base), base_index);
-}
-
-/** Returns the index of a base class.
- * @param smoke the Smoke module
- * @param class_index the class index
- *
- * @return the index of a parent
- */
-Smoke::Index
-smoke_get_parent_index(void* smoke, Smoke::Index class_index)
-{
- Q_ASSERT(class_index >= 0);
-
- return get_smoke(smoke)->inheritanceList[class_index];
-}
-
-//////////////////////////////
-/// Method
-//////////////////////////////
-
-/** Gets the method map.
- * @param smoke the Smoke module
- * @param method the index of the method
- *
- * @return a pointer to the @c MethodMap entry.
- */
-const Smoke::MethodMap*
-smoke_get_method_map(void* smoke, Smoke::Index method)
-{
- Q_ASSERT(method >= 0 && method <= get_smoke(smoke)->numMethodMaps);
-
- return &get_smoke(smoke)->methodMaps[method];
-}
-
-/** Gets a methods name.
- * @param smoke the Smoke module
- * @param method_name the method name index
- *
- * @return the method name
- */
-const char*
-smoke_get_method_name(void* smoke, Smoke::Index method_name)
-{
- Q_ASSERT(method_name >= 0 && method_name <= get_smoke(smoke)->numMethodNames);
-
- return get_smoke(smoke)->methodNames[method_name];
-}
-
-/** Gets the number of method names.
- * @param smoke the Smoke module
- *
- * @return the number of method names
- */
-Smoke::Index
-smoke_method_name_size(void *smoke)
-{
- return get_smoke(smoke)->numMethodNames;
-}
-
-/** Gets the number of methods.
- * @param smoke the Smoke module
- *
- * @return the number of methods
- */
-Smoke::Index
-smoke_methods_size(void* smoke)
-{
- return get_smoke(smoke)->numMethods;
-}
-
-/** Gets a method.
- * @param smoke the smoke binding
- * @param method the index of the method
- *
- * @return a pointer to the method struct
- */
-const struct Smoke::Method*
-smoke_get_method(void* smoke, Smoke::Index method)
-{
- Q_ASSERT(method >= 0 && method <= smoke_methods_size(smoke));
-
- return &get_smoke(smoke)->methods[method];
-}
-
-/** Finds a method of a class.
- * @param m pointer to write the result to
- * @param smoke the smoke binding
- * @param class_index index of the class
- * @param method_name method name
- */
-void
-smoke_find_method(Smoke::ModuleIndex* m, void* smoke,
- Smoke::Index class_index, const char* method_name)
-{
- *m = get_smoke(smoke)->findMethod(get_smoke(smoke)->className(class_index),
- method_name);
- if(m->index > 0)
- m->index = smoke_get_method_map(m->smoke, m->index)->method;
-}
-
-/** Gets the type index of an argument.
- * @param smoke the smoke binding
- * @param argument the argument index
- *
- * @return the type index
- */
-Smoke::Index
-smoke_get_argument(void* smoke, Smoke::Index argument)
-{
- Q_ASSERT(argument >= 0);
-
- return get_smoke(smoke)->argumentList[argument];
-}
-
-/** Calls a method.
- * The methods return value is stored in the first element of the stack.
- * @param smoke the smoke binding
- * @param method the index of the method
- * @param object A pointer to the class instance, or NULL for static and constructor calls
- * @param stack The stack with the methods arguments.
- *
- * @return NULL on success or a description of the exception that occurred.
- */
-const char*
-smoke_call_method(void* smoke, Smoke::Index method, void* object,
- Smoke::Stack stack)
-{
- Smoke::Method meth = *smoke_get_method(smoke, method);
- Q_ASSERT(!(meth.flags & Smoke::mf_internal));
- Q_ASSERT_X((NULL == object
- && (meth.flags & (Smoke::mf_static
- | Smoke::mf_enum
- | Smoke::mf_copyctor
- | Smoke::mf_ctor)))
- || object,
- __func__, "object is NULL");
- Q_ASSERT(meth.flags & Smoke::mf_ctor ? NULL == object : true);
- const Smoke::Class* klass = smoke_get_class(smoke, meth.classId);
-
- try
- {
- Q_ASSERT(klass->classFn != NULL);
- (*klass->classFn)(meth.method, object, stack);
- }
- catch (std::exception& e)
- {
- qFatal(e.what());
- return e.what();
- }
- catch (...)
- {
- qFatal("exception");
- return NULL;
- }
-
- return NULL;
-}
-
-///////////////////////////
-/// Type
-//////////////////////////
-
-/** Gets the number of types.
- * @param smoke the Smoke module
- *
- * @return the number of types
- */
-Smoke::Index
-smoke_types_size(void* smoke)
-{
- return get_smoke(smoke)->numTypes;
-}
-
-/** Gets a type.
- * @param smoke the Smoke module
- * @param type the index of the type
- *
- * @return a pointer to the type struct
- */
-const struct Smoke::Type*
-smoke_get_type(void* smoke, Smoke::Index type)
-{
- Q_ASSERT(type >= 0 && type <= smoke_types_size(smoke));
-
- return &get_smoke(smoke)->types[type];
-}
-
-/** Gets the index of a type.
- * @param smoke the Smoke module
- * @param name the types name
- *
- * @return the index of the type
- */
-Smoke::Index
-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 objec
- * @param from the class index of @a object
- * @param to the class index to cast to
- *
- * @return the casted object
- */
-void*
-smoke_cast(void* smoke, void* object, Smoke::Index from, Smoke::Index to)
-{
- Q_ASSERT(from > 0 && from <= smoke_classes_size(smoke));
- Q_ASSERT(to > 0 && to <= smoke_classes_size(smoke));
-
- return get_smoke(smoke)->cast(object, from, to);
-}
-
-/** Gets an ambiguous method.
- * @param smoke the Smoke module
- * @param ambiguous the index
- *
- * @return the index of a method
- */
-Smoke::Index
-smoke_ambiguous_method(void* smoke, Smoke::Index ambiguous)
-{
- Q_ASSERT(ambiguous >= 0);
-
- return get_smoke(smoke)->ambiguousMethodList[ambiguous];
-}
-
-} // extern "C"
diff -rN -u old-smoke/src/smoke-c/smoke-c.lisp new-smoke/src/smoke-c/smoke-c.lisp
--- old-smoke/src/smoke-c/smoke-c.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/smoke-c/smoke-c.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,64 +0,0 @@
-(in-package #:smoke)
-
-(eval-when (:load-toplevel :compile-toplevel :execute)
- (define-foreign-library libsmokeqt
- (:unix "libsmokeqt.so.2")
- (t (:default "libsmokeqt")))
-
- (use-foreign-library libsmokeqt)
-
- (use-foreign-library libsmoke-c)
-)
-
-
-
-(eval-when (:load-toplevel :compile-toplevel :execute)
- (use-foreign-library libsmoke-c-util)
- (defcfun 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 'libsmoke-c-util)
- (intern (format nil "UINT~A" (* 8
- (smoke-sizeof-bool)))
- ; (foreign-funcall smoke-sizeof-bool :int)))
- (find-package :keyword)))
-
- (defmacro defcxxbool ()
- `(defctype cxx-bool (:boolean ,(cffi-bool-type)))))
-
-(defcxxbool)
-
-(close-foreign-library 'libsmoke-c-util)
-
-(defctype smoke-binding :pointer
- "A Smoke binding")
-
-(defctype smoke-index :short
- "An index")
-
-(defcfun smoke-init smoke-binding
- (smoke :pointer)
- (destruct :pointer)
- (dispatch :pointer))
-
-(defcfun smoke-destruct :void
- (smoke smoke-binding))
-
-(defcstruct smoke-module-index
- "asdf"
- (smoke :pointer)
- (index smoke-index))
-
-
-(defcfun smoke-set-binding :void
- "Sets the binding for an newly constructed instance."
- (smoke :pointer)
- (smoke-binding smoke-binding)
- (class smoke-index)
- (object :pointer))
-
-(defcfun smoke-get-smoke :pointer
- (smoke-binding smoke-binding))
-
-(defcfun smoke-get-module-name :string
- (smoke :pointer))
diff -rN -u old-smoke/src/smoke-c/stack.lisp new-smoke/src/smoke-c/stack.lisp
--- old-smoke/src/smoke-c/stack.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/smoke-c/stack.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,21 +0,0 @@
-(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/smoke-c/type.lisp new-smoke/src/smoke-c/type.lisp
--- old-smoke/src/smoke-c/type.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/smoke-c/type.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,28 +0,0 @@
-(in-package #:smoke)
-
-(defcenum smoke-type-flags
- "Type properties"
- (:type-id #x0F)
-
- (:stack #x10)
- (:pointer #x20)
- (:reference #x30)
-
- (:const #x40))
-
-(defcstruct smoke-type
- "A type"
- (name :string)
- (class smoke-index)
- (flags :unsigned-short))
-
-(defcfun smoke-find-type smoke-index
- (smoke :pointer)
- (name :string))
-
-(defcfun smoke-types-size smoke-index
- (smoke :pointer))
-
-(defcfun smoke-get-type (:pointer smoke-type)
- (smoke :pointer)
- (type smoke-index))
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-30 08:15:09.000000000 +0100
@@ -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 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/smoke.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -1,145 +1,215 @@
+;;; Copyright (C) 2009, 2010 Tobias Rautenkranz <tobias@rautenkranz.ch>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+;;;
+;;; 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 (optimize (debug 3)))
+(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 &optional (args nil))
+(defun s-call (method object-pointer &optional (args nil))
(with-stack (stack args (arguments method) )
- (smoke-call-method (smoke method) (id method)
- object (pointer stack))
- (type-to-lisp (pointer stack) (return-type 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 &optional (args nil))
+(defun pointer-call (method object-pointer &optional (args nil))
(with-stack (stack args (arguments method) )
- (smoke-call-method (smoke method) (id method)
- object (pointer stack))
- (foreign-slot-value (pointer stack) 'smoke-stack-item 'class)))
-
+ (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 class method-name)
- pointer args))
-
-(defun static-call (smoke class-name method-name &rest args)
- (s-call
- (make-smoke-method (make-smoke-class smoke class-name)
- method-name)
- (null-pointer) args))
+ (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)
+ ;; and confuses it with the member function type() ?? (27.2.09)
;;
(assert (enum-p method))
(with-stack (stack nil nil)
- (smoke-call-method (smoke method) (id method)
- (null-pointer) (pointer stack))
- (foreign-slot-value (pointer stack) 'smoke-stack-item 'long)))
-
-#|
-(defun new-object (binding class-name method-name &rest args)
- (let* ((smoke (smoke-get-smoke binding))
- (pointer
- (pointer-call
- (make-smoke-method (make-smoke-class smoke class-name)
- method-name)
- (null-pointer) args)))
- (let ((object (instance-to-lisp object (find-smoke-class class)
- (return-type)))
-|#
-(defun new-object (binding class-name method-name &rest args)
- (let* ((smoke (smoke-get-smoke binding))
- (method (make-smoke-method (make-smoke-class smoke class-name)
- method-name))
- (pointer
- (pointer-call method (null-pointer) args))
- (object (instance-to-lisp pointer
- (find-smoke-class (get-class (return-type method)))
- (return-type method))))
- (set-binding object (binding (smoke (class-of object))))
- (add-object object)
- object))
-
+ (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 destrutor and frees the memory."
- (let ((method-name (concatenate 'string "~" (name class))))
- (s-call
- (make-smoke-method class method-name)
- pointer))
- (setf pointer (null-pointer)))
+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)
- (let ((method-name (concatenate 'string "~" (name object))))
- (s-call
- (make-smoke-method object method-name)
- (pointer object)))
+ (delete-pointer (pointer object) (class-of object))
(setf (slot-value object 'pointer) (null-pointer)))
-(defun set-binding (object binding)
- (smoke-set-binding (smoke (class-of object)) binding (id (class-of object)) (pointer object)))
+(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 init (smoke)
- "Returns the a new Smoke binding for the Smoke module SMOKE."
- (use-foreign-library libsmoke-c)
- (let ((binding (smoke-init smoke
- (callback destructed)
- (callback dispatch-method))))
- (setf (binding smoke) binding)
- binding))
+(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))
+ (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)))
-;; No eql T since all-methods is to slow to be used in conjunction with
-;; mb:document
-(defmethod documentation ((gf smoke-gf) (doc-type (eql 'cxx-function)))
+(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."
- ;;FIXME speed this up, needed by (mb:document :smoke).
- (declare (string name)
- (optimize (speed 3)))
+ (declare (optimize (speed 3)))
+ (with-foreign-string (name name)
(let ((methods))
- (maphash #'(lambda (address value)
- (declare (ignore value))
- (let ((smoke (make-pointer address)))
- (map-methods #'(lambda (method)
- (when (and (string= name (name method))
- (not (enum-p method)))
- (push (make-instance 'smoke-method
- :id (id method)
- :smoke (smoke method))
- methods)))
- smoke)))
- *smoke-id-class-map*)
- 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))
- (format t "~A::~A~%" (name (get-class method))
- (signature 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/translate.lisp new-smoke/src/translate.lisp
--- old-smoke/src/translate.lisp 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/src/translate.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,26 +0,0 @@
-(in-package :smoke)
-
-(defvar *type-map* (make-hash-table :test 'equal))
-
-(defun get-type (name)
- "Return the CFFI type for NAME."
- (gethash name *type-map*))
-
-(defun add-type (name type)
- "Registers the CFFI type TYPE with NAME."
- (setf (gethash name *type-map*) type))
-
-(defun setup-type-map ()
- "Setup C string <-> Lisp string translation."
- (add-type "char*" :string)
- (add-type "const char*" :string))
-
-(eval-when (:load-toplevel :execute)
- (setup-type-map))
-
-(defgeneric convert-to-class (smoke-class object))
-
-;(defmethod convert-to-class (smoke-class (pointer cffi:foreign-pointer))
-(defmethod convert-to-class (smoke-class pointer)
- (assert (cffi:pointerp pointer))
- pointer)
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-30 08:15:09.000000000 +0100
@@ -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/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-30 08:15:09.000000000 +0100
@@ -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-30 08:15:09.000000000 +0100
@@ -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-30 08:15:09.000000000 +0100
@@ -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-30 08:15:09.000000000 +0100
@@ -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-30 08:15:09.000000000 +0100
@@ -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 2014-10-30 08:15:09.000000000 +0100
+++ new-smoke/test.lisp 2014-10-30 08:15:09.000000000 +0100
@@ -1,25 +1,28 @@
#|
-exec -a "$0" sbcl --noinform --noprint --disable-debugger --load $0 --end-toplevel-options "$@"
-# do not use --script to allow loading mudballs with ${HOME}/.sbclrc
+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)
-(in-package :sysdef-user)
-
-(defun load-sysdef (pathname system)
- (load pathname)
- (setf (mb.sysdef::pathname-of (find-system system)) pathname))
-
-(defun load-sysdef-file (system-name)
- "Loads a mbd file in the current directory."
- (load-sysdef (make-pathname :defaults *default-pathname-defaults*
- :name (string-downcase system-name)
- :type "mbd")
- system-name))
-
-(load-sysdef-file :smoke)
-(mb:clean :smoke)
-(mb:test :smoke)
-
-(sb-ext:quit)
+#+sbcl (sb-ext:quit)
+#+ccl (ccl:quit)