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.
diff -rN -u old-smoke/CMakeLists.txt new-smoke/CMakeLists.txt
--- old-smoke/CMakeLists.txt 2014-10-01 21:50:02.000000000 +0200
+++ new-smoke/CMakeLists.txt 2014-10-01 21:50:02.000000000 +0200
@@ -3,6 +3,5 @@
project(smoke)
add_subdirectory(src)
-add_subdirectory(examples)
include(UseDoxygen OPTIONAL)
diff -rN -u old-smoke/TODO new-smoke/TODO
--- old-smoke/TODO 2014-10-01 21:50:01.000000000 +0200
+++ 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-01 21:50:02.000000000 +0200
@@ -0,0 +1,60 @@
+(defsystem :cl-smoke.smoke
+ :name :cl-smoke.smoke
+ :version (0 0 1)
+ :author "Tobias Rautenkranz"
+ :license "GPL with linking exception"
+ :description "Smoke bindings. Provides the base functionality to
+implement bindings using the various Smoke modules."
+ :depends-on
+ (:cffi :closer-mop :alexandria :trivial-garbage :bordeaux-threads
+ #+(and sbcl unix) :sb-posix)
+
+ :components
+ ((:module :src :components
+ ((:file "package")
+ (:file "using-type" :depends-on ("package"))
+ (:file "overload-resolution" :depends-on ("package" "smoke" "using-type"))
+ #+sbcl (:file "sb-optimize" :depends-on ("overload-resolution"))
+ (:file "smoke" :depends-on (:libsmoke :objects "clos"))
+ (:file "object-map" :depends-on (:objects :utils))
+ (:file "class-map" :depends-on ("package"))
+ (:file "bindings" :depends-on ("package" :utils))
+ (:file "cxx-method" :depends-on ("package"))
+ (:file "clos" :depends-on (:libsmoke "cxx-method" :objects
+ "object-map" "class-map" "bindings"))
+ (:file "smoke-to-clos" :depends-on ("clos" "overload-resolution"))
+ (:module :objects
+ :serial t
+ :depends-on (:libsmoke :utils "bindings")
+ :components
+ ((:file "object") (:file "enum" :depends-on ("object"))
+ (:file "type" :depends-on ("enum"))
+ (:file "method" :depends-on ("type"))
+ (:file "class" :depends-on ("method"))
+ (:file "instance" :depends-on ("class"))
+ (:file "stack" :depends-on ("instance"))))
+ (:module :libsmoke
+ :depends-on ("package")
+ :components
+ ((:file "smoke")
+ (:file "class" :depends-on ("smoke"))
+ (:file "stack" :depends-on ("class"))
+ (:file "method" :depends-on ("stack"))
+ (:file "type" :depends-on ("method"))))
+ (:module :utils
+ :depends-on ("package")
+ :components
+ ((:file "get-value")
+ #+(and sbcl unix) (:file "sbcl-bundle")
+ (:module :image :components
+ ((:file "image" :depends-on (:impl))
+ (:module :impl
+ :components
+ (#+sbcl (:file "sbcl")
+ #+openmcl (:file "ccl")
+ #+(not (or sbcl openmcl))
+ (:file "not-implemented")))))))))))
+
+(defmethod perform ((operation test-op) (c (eql (find-system :cl-smoke.smoke))))
+ (operate 'asdf:load-op :cl-smoke.qt.tests)
+ (operate 'asdf:test-op :cl-smoke.qt.tests))
diff -rN -u old-smoke/examples/CMakeLists.txt new-smoke/examples/CMakeLists.txt
--- old-smoke/examples/CMakeLists.txt 2014-10-01 21:50:02.000000000 +0200
+++ 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-01 21:50:02.000000000 +0200
+++ 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-01 21:50:01.000000000 +0200
+++ new-smoke/smoke.mbd 1970-01-01 01:00:00.000000000 +0100
@@ -1,79 +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)
- ((package :initarg :package)))
-;;; 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")
- (:license "GPL with linking exception")
- (:components
- ("CMakeLists" cmake-file)
- (:src module
- (:needs "CMakeLists")
- (:components
- "package"
- ("translate" (:needs "package"))
- ("using-type" (:needs "package"))
- ("overload-resolution" (:needs "package" "smoke" "using-type"))
- ("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" "overload-resolution"))
- (:objects module
- (:needs "smoke-c" "utils")
- (:serial t)
- (:components "object" "enum" "type" "method" "class"
- "instance" "stack"))
- (:smoke-c module
- (:needs "package" "translate")
- (:components ("libsmoke-c" cmake-library)
- ("libsmoke-c-util" cmake-library)
-
- ("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")
- (:requires (:sb-posix (:for :sbcl)))
- (:components
- "get-value"
- ("sbcl-bundle" (:for :sbcl))
- (:image module
- (:components
- ("image" (:needs "impl"))
- (:impl module
- (:components
- ("sbcl" (:for :sbcl))
- ("ccl" (:for :openmcl))
- ("not-implemented" (:for (:not
- (:or :sbcl :openmcl)))))))))))))
- (:supports (:os :linux) (:implementation :sbcl :openmcl))
- (:needs :sysdef.cmake :cffi :closer-mop
- :alexandria :trivial-garbage :bordeaux-threads))
diff -rN -u old-smoke/src/CMakeLists.txt new-smoke/src/CMakeLists.txt
--- old-smoke/src/CMakeLists.txt 2014-10-01 21:50:01.000000000 +0200
+++ new-smoke/src/CMakeLists.txt 2014-10-01 21:50:02.000000000 +0200
@@ -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-01 21:50:02.000000000 +0200
+++ new-smoke/src/bindings.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -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-01 21:50:02.000000000 +0200
+++ new-smoke/src/class-map.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -5,36 +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.
-
(defun id-class-map (smoke)
- (let ((value (gethash (pointer-address smoke)
+ (let ((value (gethash (pointer-address (smoke-module-pointer smoke))
*smoke-id-class-map*)))
- (assert value
- ()
- "Unknown smoke module ~A ~A."
- smoke (smoke-get-module-name smoke))
+ (assert value () "Unknown smoke module ~A." smoke)
value))
(defun (setf id-class-map) (new-value smoke)
- (setf (gethash (pointer-address smoke) *smoke-id-class-map*)
+ (setf (gethash (pointer-address (smoke-module-pointer smoke))
+ *smoke-id-class-map*)
new-value))
(defun add-id-class-map (smoke)
- (setf (id-class-map smoke)
- (make-hash-table)))
+ (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-01 21:50:02.000000000 +0200
+++ new-smoke/src/clos.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -9,7 +9,6 @@
(values (intern (cxx-to-lisp name)))
(values (intern (cxx-to-lisp name) package))))
-
(defmacro define-string-transform (name documentation &body states)
"Defines a function to transform a string."
(let ((output (gensym))
@@ -19,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))
@@ -52,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))
@@ -74,13 +73,13 @@
(define-string-transform cxx-to-lisp
"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 #\-)
@@ -92,7 +91,7 @@
(go-next camel-case)
(go-next default)))))
(namespace
- "Convert camelCase to lisp-style."
+ "C++ namespace separator"
(assert (eql #\: char))
(append-char #\.)
(go-next default))
@@ -109,6 +108,8 @@
(defmethod print-object ((object smoke-standard-object) stream)
(if (slot-boundp object 'pointer)
(print-unreadable-object (object stream :type t)
+ (when (const-p object)
+ (princ "CONST " stream))
(princ (pointer object) stream))
(call-next-method)))
@@ -117,102 +118,117 @@
(:documentation "A Smoke C++ class"))
(defclass cxx:class (smoke-standard-class)
- ((smoke :reader smoke-symbol :initarg :smoke-symbol
- :type symbol))
+ ()
(:documentation "Metaclass to extend Smoke Objects."))
-(defmethod smoke ((class cxx:class))
- (eval (smoke-symbol class)))
-
+(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 reinitialize-instance :around ((class smoke-standard-class) &rest args)
+ (apply #'init-smoke-standard-class class #'call-next-method args))
-(defmethod closer-mop:validate-superclass ((class cxx:class) (superclass smoke-standard-class))
- T)
-
-(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 cxx: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 (get-smoke-variable-for-pointer (smoke superclass))
- :direct-superclasses direct-superclasses
- args)))
-(defmethod initialize-instance :around
- ((class cxx: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 class ~A has a non virtual destructor." 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 (get-smoke-variable-for-pointer (smoke superclass))
+ :smoke (smoke superclass)
:direct-superclasses direct-superclasses
+ :direct-default-initargs direct-default-initargs
args)))
-(defun smoke-class-symbol (smoke-class)
- "Returns the Lisp class-name of SMOKE-CLASS:"
- (if (external-p smoke-class)
- (class-name (find-smoke-class smoke-class))
- (lispify (name smoke-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 (package smoke)
- "Construts a lisp class in PACKAGE for each one in the Smoke module SMOKE."
- (declare (foreign-pointer smoke)
- (optimize (speed 3)))
- (let ((*package* (find-package package)))
- (add-id-class-map 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)))))
+ (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)
@@ -222,9 +238,11 @@
(:metaclass closer-mop:funcallable-standard-class)
(:documentation "Smoke generic function."))
+(declaim (inline smoke-class-of))
(defun smoke-class-of (object)
- "Returns the class of OBJECT or OBJECT iff it 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)))
@@ -232,7 +250,8 @@
;;; ENSURE-METHOD is only called as needed.
(defmethod no-applicable-method ((gf smoke-gf) &rest args)
"Calls the smoke method."
- (declare (optimize (speed 3)))
+ (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)
@@ -248,208 +267,296 @@
(list ,@(rest lambda-list))))))))
(defcallback destructed :void
- ((binding :pointer)
- (id smoke-index)
- (object-pointer :pointer))
- (declare (ignore binding id)
- (optimize (speed 3)))
+ ((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))))))
-
-(defun convert-argument (argument type &optional (user t))
- "Returns ARGUMENT converted to TYPE. If USER is true, user defined
-conversion sequences are considered."
- (let ((rank (get-conversion-sequence argument type user)))
- (if (null rank)
- (error "Can not convert the argument ~S to ~A."
- argument (name type))
- (funcall (conversion-function-name rank)
- argument))))
+ (cons (argument-to-lisp (mem-ref stack 'smoke-stack-item)
+ arg)
+ args))))
+
+(defun convert-argument (argument type &optional disown)
+ "Returns ARGUMENT converted to TYPE and removes the ownership when
+it is passed on the stack."
+ (flet ((disown (object)
+ (remove-finalizer object)
+ (when (typep object 'smoke-standard-object)
+ (remove-object (pointer object)))))
+ (let ((rank (get-conversion-sequence argument type nil)))
+ (if (null rank)
+ (let ((rank (get-conversion-sequence argument type t)))
+ (if (null rank)
+ (error "Can not convert the argument ~S to ~A."
+ argument (name type))
+ (let ((ret (funcall (conversion-function-name rank)
+ argument)))
+ (when (and disown (stack-p type))
+ (disown ret))
+ ret)))
+ (prog1 (funcall (conversion-function-name rank) argument)
+ (when (and disown (stack-p type))
+ (disown argument)))))))
(defun put-returnvalue (stack value type object)
(unless (void-p type)
(let ((stack (make-call-stack stack)))
- (setf (top stack) (pointer stack))
- ;; FIXME support user conversions.
- ;; We need to determine which of value and converted-value is
- ;; passed on the stack. E.g. converted-value can be something like
- ;; (cxx:operator-variant value).
- (let ((converted-value (convert-argument value type nil)))
- (push-smoke-stack stack converted-value (type-id type))
- (when (stack-p type) ;; Pass by value => smoke deletes the object.
- (cancel-finalization converted-value)
- (when (typep value 'smoke-standard-object)
- (transfer-ownership-to value object)))))))
+ (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)
- (stack smoke-stack)
- (abstract :boolean))
+ ((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))))
- (loop
- (restart-case
- (return-from dispatch-method
- (let ((gf (get-gf-for-method method)))
- (if (null (gf-methods gf))
- (progn
- (when abstract
- (error "Abstract method ~A called."
- (method-declaration 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)
- object)
- t)
- nil)))))
- (call-default ()
- :report (lambda (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)
- (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))
- (return-from dispatch-method t))
- (return ()
- :report (lambda (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)
- (format stream "Try again calling ~A"
- (method-declaration method))))))))
+ (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 call-constructor (object arguments)
- (if (null arguments)
- (let ((method (find-smoke-method (class-of object)
- (name (class-of object)))))
- (pointer-call method (null-pointer)))
- (multiple-value-bind (method sequence)
- (find-best-viable-function (name (class-of object))
- arguments
- (class-of object))
- (when (null method)
- (error "No construtor ~A for ~S"
- object arguments))
- (pointer-call method (null-pointer)
- (mapcar #'(lambda (conversion argument)
- (funcall conversion argument))
- sequence arguments)))))
+;; 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))))
+ (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
- :pointer pointer)))
+ (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)
- #-clisp
+ (declare (type smoke-standard-object object)
+ (optimize (speed 3)))
(when (member object (owned-objects new-owner))
- (cerror "ignore" "~A has already been called for ~A."
- #'keep-wrapper object))
+ (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++."
- (cancel-finalization object)
+ (declare (optimize (speed 3)))
+ (remove-finalizer object)
(if (virtual-destructor-p (class-of object))
(keep-wrapper object new-owner)
(remove-object (pointer object))))
@@ -459,5 +566,4 @@
cl-smoke is responsible for deleting the object."
(when current-owner
(remove-wrapper-object object current-owner))
- (let ((finalizer (make-finalize object)))
- (finalize object finalizer)))
+ (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-01 21:50:01.000000000 +0200
+++ new-smoke/src/cxx-method.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -1,13 +1,11 @@
(in-package :smoke)
(defclass cxx-generic-function (standard-generic-function)
- ((gf-methods :initform nil
+ ((gf-methods :initform nil :type list
:accessor gf-methods
- :type list
- :documentation "Generic functions for different argument counts."))
+ :documentation "gf for different argument counts."))
(:metaclass closer-mop:funcallable-standard-class)
- (:documentation
- "A generic function that can be overloaded by argument count."))
+ (:documentation "gf that can be overloaded by argument count."))
(defclass cxx-method-generic-function (standard-generic-function)
((generic-function :accessor cxx-generic-function
@@ -36,8 +34,7 @@
((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)
@@ -75,13 +72,14 @@
"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)
@@ -105,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))
@@ -120,7 +118,7 @@
#+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))
@@ -152,7 +150,7 @@
#|
(defun cxx-dispatch-compiler-macro (cxx-generic-function)
- "Retruns a compiler-macro form for CXX-GENERIC-FUNCTION that
+ "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.
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-01 21:50:02.000000000 +0200
@@ -0,0 +1,39 @@
+find_package(Qt4 REQUIRED)
+set(QT_DONT_USE_QTGUI true)
+include(${QT_USE_FILE})
+
+include(CheckCXXCompilerFlag)
+check_cxx_compiler_flag("-fvisibility=hidden" CXX_VISIBILITY)
+if(CXX_VISIBILITY)
+ set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -fvisibility=hidden -fvisibility-inlines-hidden")
+endif(CXX_VISIBILITY)
+
+
+# FIXME look for smoke.h
+find_library(smokebase_LIB smokebase)
+if (smokebase_LIB)
+ set(smokebase_FOUND TRUE)
+endif (smokebase_LIB)
+
+if (smokebase_FOUND)
+ message(STATUS "Found smokebase: ${smokebase}")
+else (smokebase_FOUND)
+ message(FATAL_ERROR "Could not find smokebase")
+endif (smokebase_FOUND)
+
+
+set(SMOKE_C_SOURCES smoke.cpp smokebinding.cpp)
+add_library(clsmoke SHARED ${SMOKE_C_SOURCES})
+target_link_libraries(clsmoke ${QT_LIBRARIES} ${smokebase_LIB})
+set_target_properties(clsmoke
+ PROPERTIES
+ SOVERSION "0.0"
+ VERSION "0.0.1")
+
+add_library(clsmokeutil SHARED smoke_util.cpp)
+set_target_properties(clsmokeutil
+ PROPERTIES
+ SOVERSION "0.0"
+ VERSION "0.0.1")
+
+install(TARGETS clsmoke clsmokeutil DESTINATION lib)
diff -rN -u old-smoke/src/libsmoke/cl_smoke.h new-smoke/src/libsmoke/cl_smoke.h
--- old-smoke/src/libsmoke/cl_smoke.h 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/cl_smoke.h 2014-10-01 21:50:02.000000000 +0200
@@ -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-01 21:50:02.000000000 +0200
@@ -0,0 +1,44 @@
+(in-package #:smoke)
+
+(defcenum smoke-class-flags
+ "Class properties"
+ (:constructor #x01)
+ (:copy-constructor #x02)
+ (:virtual-destructor #x04)
+ (:namespace #x08)
+ (:undefined #x10))
+
+(defcstruct smoke-class
+ "Describe a class"
+ (name :string)
+ (external cxx-bool)
+ (parents smoke-index)
+ (class-function :pointer)
+ (enum-function :pointer)
+ (flags :unsigned-short)
+ (size :unsigned-int))
+
+(defcfun (smoke-find-class "cl_smoke_find_class") :void
+ (m :pointer smoke-module-index)
+ (name :string))
+
+(declaim (inline smoke-class-id))
+(defcfun (smoke-class-id "cl_smoke_class_id") smoke-index
+ (smoke :pointer)
+ (name :string))
+
+(defcfun (smoke-get-class "cl_smoke_get_class") (:pointer smoke-class)
+ (smoke :pointer)
+ (class smoke-index))
+
+(defcfun (smoke-is-derived-from "cl_smoke_is_derived_from") :boolean
+ (smoke :pointer)
+ (class smoke-index)
+ (smoke-base :pointer)
+ (base-class smoke-index))
+
+(defcfun (smoke-cast "cl_smoke_cast") :pointer
+ (smoke :pointer)
+ (object :pointer)
+ (from smoke-index)
+ (to smoke-index))
diff -rN -u old-smoke/src/libsmoke/method.lisp new-smoke/src/libsmoke/method.lisp
--- old-smoke/src/libsmoke/method.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/method.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -0,0 +1,41 @@
+(in-package #:smoke)
+
+(defcenum smoke-method-flags
+ "Method flags"
+ (:static #x01)
+ (:const #x02)
+ (:copy-constructor #x04)
+ (:internal #x08)
+ (:enum #x10)
+ (:constructor #x20)
+ (:destructor #x40)
+ (:protected #x80)
+ (:attribute #x100)
+ (:property #x200)
+ (:virtual #x400)
+ (:purevirtual #x800)
+ (:signal #x1000)
+ (:slot #x2000))
+
+(defcstruct smoke-method
+ "Describe a method"
+ (class smoke-index)
+ (name smoke-index)
+ (arguments smoke-index)
+ (num-args :unsigned-char)
+ (flags :unsigned-short)
+ (return-type smoke-index)
+ (method smoke-index))
+
+(defcstruct smoke-method-map
+ "Maps a munged method."
+ (class-id smoke-index)
+ (name smoke-index)
+ (method smoke-index))
+
+(declaim (inline smoke-find-method))
+(defcfun (smoke-find-method "cl_smoke_find_method") :void
+ (m :pointer smoke-module-index)
+ (smoke :pointer)
+ (class smoke-index)
+ (method :string))
diff -rN -u old-smoke/src/libsmoke/smoke.cpp new-smoke/src/libsmoke/smoke.cpp
--- old-smoke/src/libsmoke/smoke.cpp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/smoke.cpp 2014-10-01 21:50:02.000000000 +0200
@@ -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-01 21:50:02.000000000 +0200
@@ -0,0 +1,72 @@
+(in-package #:smoke)
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+ (define-foreign-library libclsmoke
+ (:darwin "libclsmoke.dylib")
+ (:unix "libclsmoke.so")
+ (t (:default "libclsmoke")))
+ (define-foreign-library libclsmokeutil
+ (:darwin "libclsmokeutil.dylib")
+ (:unix "libclsmokeutil.so")
+ (t (:default "libclsmokeutil")))
+ (use-foreign-library libclsmoke))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+ (use-foreign-library libclsmokeutil)
+ (defcfun (smoke-sizeof-bool "cl_smoke_sizeof_bool") :int)
+ (defun cffi-bool-type ()
+ "Returns a cffi unsigned int type with the same size as a C++ bool."
+ (load-foreign-library 'libclsmokeutil)
+ (intern (format nil "UINT~A" (* 8 (smoke-sizeof-bool)))
+ (find-package :keyword)))
+
+ (defmacro defcxxbool ()
+ `(defctype cxx-bool (:boolean ,(cffi-bool-type)))))
+
+(defcxxbool)
+
+;(close-foreign-library 'libclsmokeutil)
+
+(defctype smoke-binding :pointer
+ "A Smoke binding")
+
+(defctype smoke-index :short
+ "An index")
+
+(deftype smoke-index (&optional (lower -32768) (upper 32767))
+ "Smoke index."
+ `(integer ,lower ,upper))
+
+(defcfun (smoke-construct-binding "cl_smoke_construct_binding") smoke-binding
+ (destruct :pointer)
+ (dispatch :pointer))
+
+(defcfun (smoke-destruct-destruct "cl_smoke_destruct_binding") :void
+ (smoke smoke-binding))
+
+;; Smoke::ModuleIndex is a POD-struct.
+;; Thus we can treat it as a C struct.
+(defcstruct smoke-module-index
+ (smoke :pointer)
+ (index smoke-index))
+
+(defcfun (smoke-get-module-name "cl_smoke_get_module_name") :string
+ (smoke :pointer))
+
+(defcenum cl-smoke-array
+ :classes
+ :methods
+ :method-maps
+ :method-names
+ :types
+ :inheritance-list
+ :argument-list
+ :ambiguous-method-list)
+
+(defcfun cl-smoke-array :pointer
+ (smoke :pointer)
+ (array cl-smoke-array))
+
+(defcfun cl-smoke-array-size smoke-index
+ (smoke :pointer)
+ (array cl-smoke-array))
diff -rN -u old-smoke/src/libsmoke/smoke_util.cpp new-smoke/src/libsmoke/smoke_util.cpp
--- old-smoke/src/libsmoke/smoke_util.cpp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/smoke_util.cpp 2014-10-01 21:50:02.000000000 +0200
@@ -0,0 +1,27 @@
+#if defined _WIN32 || defined __CYGWIN__
+ #define CL_SMOKE_EXPORT __declspec(dllexport)
+#else
+ #if __GNUC__ >= 4
+ #define CL_SMOKE_EXPORT __attribute__((visibility("default")))
+ #else
+ #define CL_SMOKE_EXPORT
+ #endif
+#endif
+
+/** @file
+ * \@brief Utility functions
+ */
+
+extern "C" {
+
+/** Gets the size of the C++ bool type in bytes.
+ *
+ * @return the size of bool
+ */
+CL_SMOKE_EXPORT int
+cl_smoke_sizeof_bool()
+{
+ return sizeof(bool);
+}
+
+} // extern "C"
diff -rN -u old-smoke/src/libsmoke/smokebinding.cpp new-smoke/src/libsmoke/smokebinding.cpp
--- old-smoke/src/libsmoke/smokebinding.cpp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/smokebinding.cpp 2014-10-01 21:50:02.000000000 +0200
@@ -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-01 21:50:02.000000000 +0200
@@ -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-01 21:50:02.000000000 +0200
@@ -0,0 +1,21 @@
+(in-package #:smoke)
+
+(defcunion smoke-stack-item
+ "A variable on the Smoke stack"
+ (voidp :pointer)
+ (bool cxx-bool)
+ (char :char)
+ (uchar :unsigned-char)
+ (short :short)
+ (ushort :unsigned-short)
+ (int :int)
+ (uint :unsigned-int)
+ (long :long)
+ (ulong :unsigned-long)
+ (float :float)
+ (double :double)
+ (enum-value :long)
+ (class :pointer))
+
+(defctype smoke-stack (:pointer smoke-stack-item)
+ "A Smoke call stack.")
diff -rN -u old-smoke/src/libsmoke/type.lisp new-smoke/src/libsmoke/type.lisp
--- old-smoke/src/libsmoke/type.lisp 1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/libsmoke/type.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -0,0 +1,20 @@
+(in-package #:smoke)
+
+(defcenum smoke-type-flags
+ "Type properties"
+ (:type-id #x0F)
+
+ (:stack #x10)
+ (:pointer #x20)
+ (:reference #x30)
+
+ (:const #x40))
+
+(defcstruct smoke-type
+ (name :string)
+ (class smoke-index)
+ (flags :unsigned-short))
+
+(defcfun (smoke-find-type "cl_smoke_find_type") smoke-index
+ (smoke :pointer)
+ (name :string))
diff -rN -u old-smoke/src/method.lisp new-smoke/src/method.lisp
--- old-smoke/src/method.lisp 2014-10-01 21:50:02.000000000 +0200
+++ new-smoke/src/method.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,156 +0,0 @@
-(in-package :smoke)
-(declaim (optimize (debug 3)))
-
-(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 (string= (name (get-class method))
- "Qt")
- (lispify (concatenate 'string "+" (name method)
- "+")
- package)
- (lispify (concatenate 'string
- (name (get-class method))
- ".+"
- (name method) "+")
- package))))
- (values
- `(define-constant ,symbol
- (make-instance 'enum
- :value ,(enum-call method)
- :type (make-instance 'smoke-lazy-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) 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 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 (and (= (smoke-methods-size ,smoke)
- ,(smoke-methods-size (eval smoke)))
- (= (smoke-method-name-size ,smoke)
- ,(smoke-method-name-size (eval smoke)))
- (= (smoke-types-size ,smoke)
- ,(smoke-types-size (eval smoke)))
- (= (smoke-classes-size ,smoke)
- ,(smoke-classes-size (eval smoke))))
- (error "The smoke module ~A changed, you need to recompile the lisp file."
- (smoke-get-module-name ,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
-;;; mulitiple definiton 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)
- ;; 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 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 funciton
- (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)))
- (setf (gethash (lispify name "CXX") generics)
- name))
- (when (static-p method)
- (let* ((function-symbol (static-method-symbol package method))
- (methods (gethash function-symbol function-symbols)))
- (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-instance 'smoke-method
- :id (abs id)
- :smoke (eval smoke))))
- (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 (:execute)
- (register-smoke-module-var (quote ,smoke))
- (make-smoke-classes ,package ,smoke)
- (ensure-generic-methods ',(hash-table-alist generics)))
- ,@constants
- (eval-when (:load-toplevel :execute)
- (export (quote ,exports) ,package)))))
-
diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp
--- old-smoke/src/object-map.lisp 2014-10-01 21:50:02.000000000 +0200
+++ new-smoke/src/object-map.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -6,7 +6,6 @@
(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)
@@ -21,15 +20,12 @@
"Synchronized hash table not implemented."))
(defun make-synchronized-hash-table (&key weakness)
(if weakness
- #-cmucl (make-weak-hash-table :weakness #-clisp weakness
- ;; CLISP crash with weak hash table
- ;; leak memory (see also: #'keep-wrapper)
- #+clisp nil)
+ #-cmucl (make-weak-hash-table :weakness weakness)
#+cmucl (make-hash-table :weak-p weakness)
(make-hash-table))))
;; FIXME
-;; CLISP has problems with weak hashtables and finalizers.
+;; 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
@@ -38,46 +34,56 @@
(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 destuctor which had their ownership transfered
-to C++.")
+except object with a non virtual destructor which had their ownership
+transferred to C++.")
-(declaim (inline ptr -address))
-(defun ptr-address (pointer)
- ;; CLISP returns NIL for a null pointer
- #+clisp
- (if pointer
- (pointer-address pointer)
- 0)
- #-clisp
- (pointer-address pointer))
+(eval-on-save ()
+ (tg:gc :full t) ;; Try to get all #'smoke::make-auto-pointer
+ (loop for object being the hash-value of *object-map* do
+ (warn "life object ~A ~A" object (pointer object))
+ (remove-finalizer object)
+ (setf (slot-value object 'pointer) (null-pointer)))
+ (clrhash *object-map*))
(declaim (inline get-object))
(defun get-object (pointer)
- (gethash (ptr-address pointer) *object-map*))
+ (gethash (pointer-address pointer) *object-map*))
(declaim (inline (setf get-object)))
(defun (setf get-object) (value pointer)
- (setf (gethash (ptr-address pointer) *object-map*)
+ (setf (gethash (pointer-address pointer) *object-map*)
value))
+(declaim (inline has-pointer-p))
(defun has-pointer-p (pointer)
"Returns T when there is an object for POINTER in the map and NIL otherwise."
- (nth-value 1 (gethash (ptr-address pointer) *object-map*)))
-
-(defun remove-if-exists (pointer)
- (remhash (ptr-address pointer) *object-map*))
+ (nth-value 1 (gethash (pointer-address pointer) *object-map*)))
(defun remove-object (pointer)
- (assert (has-pointer-p pointer)
- (pointer)
- "No object to remove for pointer ~A." pointer)
- (remhash (ptr-address pointer) *object-map*))
+ (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))
+ 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."))
@@ -86,15 +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)
(error (condition)
(report-finalize-error condition 't (name class) pointer))))))
-
+
+(defun debug-finalize ()
+ (eval '(defmethod make-finalize :around (object)
+ (let ((pointer (pointer object))
+ (class (class-of object))
+ (next (call-next-method)))
+ #'(lambda ()
+ (format *debug-io* "cl-smoke: finalizing: ~A..."
+ (make-instance class :pointer pointer))
+ (funcall next)
+ (format *debug-io* "done~%"))))))
+
(defun add-object (object)
- "Adds OBJECT to the pointer -> object map. It can later be retrived
+ "Adds OBJECT to the pointer -> object map. It can later be retrieved
with GET-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 (has-pointer-p (pointer object))
+ (cerror "Overwrite the old object."
+ "There exists already a object ~A for the pointer of ~A."
+ (get-object (pointer object)) object))
(setf (get-object (pointer object)) object))
diff -rN -u old-smoke/src/objects/class.lisp new-smoke/src/objects/class.lisp
--- old-smoke/src/objects/class.lisp 2014-10-01 21:50:02.000000000 +0200
+++ new-smoke/src/objects/class.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -1,90 +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 (smoke-symbol)
- ()
- (:documentation "A class"))
+(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-get-class (smoke class) (id class))
+ (foreign-slot-value (smoke-class-pointer class)
'smoke-class slot-name))
+(define-compiler-macro class-slot-value (&whole form class slot-name)
+ (if (constantp slot-name)
+ `(foreign-slot-value (smoke-class-pointer ,class)
+ 'smoke-class ,slot-name)
+ form))
+
(defmethod name ((class smoke-class))
(class-slot-value class 'name))
+(defun name-pointer (class)
+ (mem-ref (foreign-slot-pointer (smoke-class-pointer class)
+ 'smoke-class 'name)
+ :pointer))
+
+(defun class-size (smoke-class)
+ (class-slot-value smoke-class 'size))
+
(defun map-classes (function smoke)
- "Applys FUNCTION to the classes of SMOKE."
+ "Applies FUNCTION to the classes of SMOKE."
(declare (function function)
- (foreign-pointer smoke)
(optimize (speed 3)))
(let ((class (make-instance 'smoke-class
- :id 0
:smoke smoke)))
- (loop for id from 1 to (1- (the fixnum (smoke-classes-size smoke))) do
- (setf (slot-value class 'id) id)
+ (loop for id from 1 to (smoke-array-length (smoke-module-classes smoke)) do
+ (setf (slot-value class 'id)
+ id)
(funcall function class))))
(defun external-p (class)
"Returns T when CLASS is external in its module; NIL otherwise."
+ (declare (type smoke-class class)
+ (optimize (speed 3)))
(class-slot-value class 'external))
-(defmethod get-flag ((class smoke-class) flag)
- (boole boole-and (class-slot-value class 'flags)
- (foreign-enum-value 'smoke-class-flags flag)))
+(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-flag class :virtual-destructor)))
+ (/= 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)
@@ -93,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 (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-01 21:50:01.000000000 +0200
+++ new-smoke/src/objects/enum.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -3,7 +3,6 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :smoke :cxx-support))
-;;;
;;; One could map enum-values to lisp symbols, store the type in the plist
;;; an use those as enums, but C++ enums may have several symbols for
;;; the same value and thus lisp symbols can not be used.
@@ -17,14 +16,11 @@
(: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)
- (declare (ignore environment))
`(make-instance 'enum
:value ,(value enum)
- :type (make-instance 'smoke::smoke-lazy-type
- :id ,(id (enum-type enum))
- :smoke ',(smoke::get-smoke-variable-for-pointer
- (smoke::smoke (enum-type enum))))))
+ :type ,(make-load-form (enum-type enum) environment)))
(defmethod print-object ((enum enum) stream)
(print-unreadable-object (enum stream :type t)
@@ -34,7 +30,7 @@
(defun check-enum-type (enum enum-type)
(assert (smoke-type= (enum-type enum)
- enum-type)
+ enum-type)
(enum enum-type)
"The enums ~A is not of type ~A." enum (name enum-type)))
@@ -42,23 +38,32 @@
"Returns true when ENUM1 and ENUM2 are equal and false otherwise."
(declare (enum enum1 enum2))
(assert (smoke-type= (enum-type enum1)
- (enum-type enum2))
+ (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))
@@ -70,8 +75,8 @@
"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)))
diff -rN -u old-smoke/src/objects/method.lisp new-smoke/src/objects/method.lisp
--- old-smoke/src/objects/method.lisp 2014-10-01 21:50:02.000000000 +0200
+++ new-smoke/src/objects/method.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -1,15 +1,34 @@
(in-package #:smoke)
-(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))
@@ -19,42 +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 unambigous-p (method)
- "Returns T when METHOD is valid and not ambiguous."
- (< 0 (id method)))
-
-(defun ambiguous-p (method)
- "Returns T when METHOD is ambiguous and NIL otherwise."
- (> 0 (id method)))
-
-(defun make-smoke-method-munged (class munged-name-id)
- "Returns the method for the MUNGED-NAME-ID of SMOKE."
- (with-foreign-object (module 'smoke-module-index)
- (smoke-find-method-for-id module (smoke class) (id class) munged-name-id)
- (make-instance 'smoke-method
- :id (foreign-slot-value module 'smoke-module-index 'index)
- :smoke (foreign-slot-value module 'smoke-module-index 'smoke))))
-
(defun find-smoke-method (class name)
"Returns the method NAME of CLASS."
(with-foreign-object (m 'smoke-module-index)
- (smoke-find-method m (smoke class) (id class) name)
- (make-instance 'smoke-method
- :id (foreign-slot-value m 'smoke-module-index 'index)
- :smoke (foreign-slot-value m 'smoke-module-index 'smoke))))
+ (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)
+(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 ambigious."
+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)))
@@ -64,29 +73,29 @@
: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))))
+ (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))))
(declaim (inline method-slot-value))
@@ -94,12 +103,25 @@
(declare (smoke-method method)
(symbol slot-name)
(optimize (speed 3)))
- (foreign-slot-value (smoke-get-method (smoke method) (id method))
+ (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)
- (method-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."
@@ -115,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 (method-slot-value method 'return-type)
- :smoke (smoke method)))
+ :smoke (smoke-method-smoke method)))
(defun method-declaration (method)
(format nil "~A~:[ void~; ~1:*~A~] ~A::~A"
@@ -131,61 +154,87 @@
(name (get-class method))
(signature method)))
-(defmethod get-flag ((method smoke-method) flag)
+(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)))
(defun internal-p (method)
"Returns T when METHOD is internal and NIL otherwise."
- (/= 0 (get-flag method :internal)))
+ (/= 0 (get-method-flag method :internal)))
-(defmethod get-class ((method smoke-method))
- (make-instance 'smoke-class
- :id (method-slot-value method 'class)
- :smoke (smoke method)))
+(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."
@@ -206,16 +255,16 @@
(defun get-first-argument (method)
"Returns the first argument of METHOD"
+ (declare (optimize (speed 3)))
(make-instance 'smoke-argument
:id (method-slot-value method 'arguments)
- :smoke (smoke method)))
+ :smoke (smoke-method-smoke method)))
(defun get-argument (method index)
"Returns the type of METHODs argument with number INDEX."
(make-instance 'smoke-argument
:id (+ (method-slot-value method 'arguments) index)
- :smoke (smoke method)))
-
+ :smoke (smoke-method-smoke method)))
(defun build-argument-list (list argument)
(if (end-p argument)
diff -rN -u old-smoke/src/objects/object.lisp new-smoke/src/objects/object.lisp
--- old-smoke/src/objects/object.lisp 2014-10-01 21:50:02.000000000 +0200
+++ new-smoke/src/objects/object.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -1,23 +1,3 @@
(in-package #:smoke)
-
-(defclass smoke-symbol ()
- ((id :reader id :initarg :id
- :type smoke-index
- :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-01 21:50:02.000000000 +0200
+++ new-smoke/src/objects/stack.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -1,48 +1,62 @@
(in-package #:smoke)
-(defclass call-stack ()
- ((pointer :reader pointer :initarg :pointer
- :initform (null-pointer)
- :type foreign-pointer
- :documentation "Pointer to the Smoke stack")
- (top :accessor top :initarg :top
- :initform (null-pointer)
- :type foreign-pointer
- :documentation "Pointer to push the next argument to."))
- (: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 alway reacable from Lisp and thus
+ ;; 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 "Objecsts owned by the C++ instance."))
+ :documentation "Objects owned by the C++ instance."))
(:documentation "The standard superclass for Smoke classes."))
(defun push-smoke-stack (stack value type-id)
+ (declare (type (smoke-index 0) type-id)
+ (type call-stack stack)
+ (optimize (speed 3)))
(ecase type-id
(0 (push-stack stack value 'voidp))
(1 (push-stack stack value 'bool))
@@ -71,7 +85,7 @@
(unless (null args)
(assert (not (null arguments))
()
- "To many arguments suppliend (Arguments ~A)." args)
+ "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
@@ -85,25 +99,22 @@
,types)
,@body))))
+(defvar *to-lisp-translations* (make-hash-table :test 'equal))
+
(defun enum-to-lisp (stack-item type)
"Returns the Lisp representation for STACK-ITEM of the basic C type TYPE."
+ (declare (optimize (speed 3)))
(ecase (type-id type)
- (0 (let ((cffi-type (get-type (name type))))
- (if (null cffi-type)
- (progn
- ;; FIXME warn but not on void**
- ;;(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)))
@@ -116,36 +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."
- (let ((object (object-to-lisp (foreign-slot-value stack-item
- 'smoke-stack-item
- 'class)
- type)))
- object))
+ (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-01 21:50:02.000000000 +0200
+++ new-smoke/src/objects/type.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -1,88 +1,133 @@
(in-package #:smoke)
-(defclass smoke-type (smoke-symbol)
- ()
- (:documentation "A type"))
+(declaim (inline smoke))
-(defclass smoke-lazy-type (smoke::smoke-type)
- ((id :reader smoke::id
- :initarg :id)
- (smoke :initarg :smoke
- :reader smoke-symbol)))
+(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 smoke::smoke ((type smoke-lazy-type))
- (eval (smoke-symbol 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 (smoke-get-type (smoke type) (id type))
+ (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))
+ (declare (optimize (speed 3)))
(type-slot-value type 'name))
(defun smoke-type= (type1 type2)
- (and t ;(pointer-eq (smoke type1)
- ; (smoke type2))
- (= (id type1)
- (id type2))))
-
-(defgeneric get-flag (object flag)
- (:documentation "Returns the value for FLAG of OBJECT."))
+ (if (eq (smoke type1) (smoke type2))
+ (= (id type1) (id type2))
+ (string= (name type1) (name type2))))
-(defmethod get-flag ((type smoke-type) flag)
+(defun get-type-flag (type flag)
+ (declare (optimize (speed 3)))
(logand (type-slot-value type 'flags)
- #xF0 ;; = ! 0x0F
- (foreign-enum-value 'smoke-type-flags flag)))
+ #xF0 ;; = !0x0F
+ (the fixnum (foreign-enum-value 'smoke-type-flags flag))))
-(defun get-allocation-flag (type)
- (logand (type-slot-value type 'flags)
- #x30))
+(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."
- (= (get-allocation-flag type) (get-flag type :stack)))
+ (allocation-flag-p type :stack))
(defun reference-p (type)
"Returns T when TYPE is a reference ('type&'); NIL otherwise."
- (= (get-allocation-flag type) (get-flag type :reference)))
+ (allocation-flag-p type :reference))
(defun pointer-p (type)
"Returns T when TYPE is a pointer ('type*'); NIL otherwise."
- (= (get-allocation-flag type) (get-flag type :pointer)))
+ (allocation-flag-p type :pointer))
(defgeneric const-p (object)
(:method ((type smoke-type))
"Returns T when TYPE is const; NIL otherwise."
- (/= 0 (get-flag type :const))))
+ (/= 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 (type-slot-value type 'class))))
+ (not (zerop (type-slot-value type 'class)))))
(defun type-id (type)
"Returns the ID of TYPE."
- (logand (type-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)."
;; void is an empty string.
- ;; For efficency just check if the first byte is a null byte;
+ ;; 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)))
- (= 0 (mem-ref (smoke-get-type (smoke type) (id type))
- :char)))
+ (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)
@@ -90,16 +135,17 @@
(defmethod get-class ((type smoke-type))
"Return the smoke-class of TYPE."
- (assert (/= -1 (type-slot-value type 'class))
+ (assert (class-p type)
(type)
- "The type ~S is not a smoke class." (name type))
- (make-instance 'smoke-class
- :id (type-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 2014-10-01 21:50:02.000000000 +0200
+++ new-smoke/src/overload-resolution.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -1,293 +1,300 @@
;;; 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)
-(defun mung-char-p (character)
- "Returns true when CHARACTER is used for munging and false otherwise."
- (declare (character character))
- (case character
- ((#\$ #\? #\#) t)))
-
-(defun binary-search-method-names (name smoke start end)
- "Returns the index of NAME for the Smoke module SMOKE and 0 when
-NAME is not found."
- ;; FIXME search methods instead of methodMaps, since we are not
- ;; interrested in the munging.
- (declare ((smoke-index 1) start end)
- (string name)
+(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 (> start end)
- 0
- (let* ((index (floor (+ end start) 2))
- (method-name (smoke-get-method-name smoke index))
- (diff (string/= method-name name)))
- (if diff
- (if (and (>= diff (length name))
- (mung-char-p (char method-name diff)))
- index
- (if (and (< diff (length name))
- (or (>= diff (length method-name))
- (char< (char method-name diff) (char name diff))))
- (binary-search-method-names name smoke (1+ index) end)
- (binary-search-method-names name smoke start (1- index))))
- index))))
-
-(defun method-name= (name munged)
- "Returns true when the name of the munged method name MUNGED is NAME."
- (let ((diff (string/= name munged)))
- (not (and diff
- (or (< diff (length name))
- (not (mung-char-p (char munged diff))))))))
-
-(defun munged-method-argument-count (munged-name)
- "Returns the number of arguments the method MUNGED-NAME uses."
- (- (1- (length munged-name))
- (position-if-not #'mung-char-p munged-name :from-end t)))
-
-(defun method-argument-count= (name munged-name argument-count)
- (declare ((integer 1 #.call-arguments-limit) argument-count))
- (and (= (length munged-name) (+ (length name) argument-count))
- (mung-char-p (char munged-name (length name)))))
-
-(defun position-method-names (name argument-count smoke start end)
- "Returns a list of the method indices with name NAME
-that accept ARGUMENT-COUNT arguments."
- (declare (string name)
- ((smoke-index 1) start end)
+ (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 ((positions (loop for i from start to end
- while (method-name= name (smoke-get-method-name smoke i))
- when (method-argument-count= name (smoke-get-method-name smoke i)
- argument-count)
- collect i)))
- (loop for i from (1- start) downto 1
- while (method-name= name (smoke-get-method-name smoke i))
- do (when (method-argument-count= name (smoke-get-method-name smoke i)
- argument-count)
- (push i positions)))
- positions))
-
-(defun smoke-modules (class)
- "Returns a list of super classes of CLASS; one or every smoke module
-that can be reached by super classes of CLASS. The returned super classes
-are as specific as possible."
- (let ((modules (list class)))
- (dolist (super-class (closer-mop:class-direct-superclasses class) modules)
- (when (and (typep super-class 'smoke-standard-class)
- (not (eql super-class (find-class 'smoke-standard-object))))
- (dolist (c (smoke-modules super-class))
- (setf modules (adjoin c modules :key #'smoke)))))))
-
-
-(defun viable-functions (name argument-count class2)
- "Returns a list of methods named NAME that take ARGUMENT-COUNT methods."
- ;; 13.3.2
- (let ((methods))
- (dolist (class (smoke-modules class2))
- (let ((index (binary-search-method-names
- name (smoke class) 1
- (smoke-method-name-size (smoke class)))))
- (loop for i in (position-method-names name argument-count (smoke class)
- index
- (smoke-method-name-size
- (smoke class)))
- do
- (let ((method (make-smoke-method-munged class i)))
- (if (unambigous-p method)
- (push method methods)
- (when (ambiguous-p method)
- (let ((index (- (id method))))
- (loop as i = (smoke-ambiguous-method (smoke method)
- index)
- while (> i 0) do
- (incf index)
- (push (make-instance 'smoke-method
- :smoke (smoke method)
- :id i)
- methods)))))))))
- methods))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-(defconstant +exact-match+ 0)
-(defconstant +promotion+ 1)
-(defconstant +conversion+ 2))
-
-(defclass std-conversion ()
- ((function-name :accessor conversion-function-name
- :initarg :conversion-function-name))
- (:documentation "A conversion"))
-
-(defclass exact-match (std-conversion)
- ((rank :reader rank
- :allocation :class
- :type fixnum
- :initform +exact-match+)))
-
-(defclass promotion (std-conversion)
- ((rank :reader rank
- :allocation :class
- :type fixnum
- :initform +promotion+)))
-
-(defclass number-conversion (std-conversion)
- ((rank :reader rank
- :allocation :class
- :type fixnum
- :initform +conversion+)))
-
-(defclass pointer-conversion (std-conversion)
- ((rank :reader rank
- :allocation :class
- :type fixnum
- :initform (1+ +conversion+))
- (from :reader from
- :initarg :from)
- (to :reader to
- :initarg :to)))
-
-(defclass boolean-conversion (std-conversion)
- ((rank :reader rank
- :allocation :class
- :type fixnum
- :initform (+ 2 +conversion+))))
-
-(defclass user-conversion (std-conversion)
- ((rank :reader rank
- :allocation :class
- :type fixnum
- :initform (+ 3 +conversion+))))
-
-(defgeneric conversion< (conversion1 conversion2)
- (:documentation
- "Retruns true when CONVERSION1 is better than CONVERSION2.")
+ (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)
- (or (null conversion2)
- (< (rank conversion1) (rank 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))
- (if (eq (from conversion1) (from conversion2))
+ (declare (optimize (speed 3)))
+ (if (eq (pointer-conversion-from conversion1)
+ (pointer-conversion-from conversion2))
;; A->B < A->C <=> B subclass of C
- (subtypep (to conversion1) (to conversion2))
- (if (eq (to conversion1) (to conversion2))
+ (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 (from conversion1) (from conversion2))
+ (subtypep (pointer-conversion-from conversion1)
+ (pointer-conversion-from conversion2))
nil))))
(defgeneric conversion= (conversion1 conversion2)
- (:documentation
- "Returns true when the standard conversion sequence CONVERSION1
- is indistinguishable from CONVERSION2.")
(:method (conversion1 conversion2)
- (= (rank conversion1) (rank conversion2)))
+ (and (conversion<= conversion1 conversion2)
+ (conversion<= conversion2 conversion1)))
(:method ((conversion1 (eql nil)) (conversion2 (eql nil)))
- t)
- (:method ((conversion1 pointer-conversion) (conversion2 pointer-conversion))
- (and (not (conversion< conversion1 conversion2))
- (not (conversion< conversion2 conversion1)))))
+ t))
(defun max-conversion (conversion1 conversion2)
"Returns the greater conversion of CONVERSION1 and CONVERSION2."
(if (null conversion2)
conversion1
- (if (conversion< conversion1 conversion2)
+ (if (conversion<= conversion1 conversion2)
conversion2
conversion1)))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun conversion-function (name &optional arg)
- (if arg
- `(if (using-typep)
- `(,,name
- (find-class ',(class-name ,arg)))
- #'(lambda (object)
- (funcall (fdefinition ,name)
- object ,arg)))
- `(if (using-typep)
- ,name
- (fdefinition ,name)))))
-
-(defmacro make-match (type &optional (name ''identity)
- (argument nil)
+(defmacro make-match (type &optional (name ''identity) (argument nil)
&rest args)
- `(make-instance ,type
- :conversion-function-name ,(conversion-function name argument)
-
- ,@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)
- "Retruns a conversion sequence to convert a instance of type CLASS
+ "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)))))
+ (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."
- (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))))
+ (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)
+(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))
+ name arguments class const-p))
-(defun+using-types find-best-viable-function2 (get-sequence name objects class)
- (declare (type (function (t list) (values t function)) get-sequence))
+(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))
+ class const-p))
(best-rank)
(best-method)
(conversions))
- (loop for method in viable-functions do
- (multiple-value-bind (rank method-conversions)
- (funcall get-sequence method objects)
- (when (and rank (conversion< rank best-rank))
- (setf best-rank rank)
- (setf best-method method)
- (setf conversions method-conversions)
- (when (conversion= rank (make-match 'exact-match))
- (return)))))
- (values best-method conversions)))
-
-(defmacro string-case ((keyform) &body clauses)
- ;; FIXME this is horribly inefficient
- `(cond ,@(mapcar #'(lambda (clause)
- `((string= ,keyform ,(first clause))
- ,@(rest clause)))
- clauses)))
-
-(defmacro smoke-type-case ((keyform class) &body clauses)
- `(string-case ((name ,keyform))
- ,@(mapcar (curry #'apply
- #'(lambda (type-name lisp-type)
- `(,type-name (typep-using-type ,class (quote ,lisp-type)))))
- clauses)))
+ (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))
@@ -298,8 +305,14 @@
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)
- (and (subtypep type ',lisp-type)
+ #'(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**")
@@ -318,9 +331,8 @@
(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.type-of))))
+ (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)))
@@ -328,9 +340,16 @@
(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 (object.typep 'enum)) ;; FIXME enum-type
+ (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))))))
@@ -350,9 +369,21 @@
(defun coerce-c-string (string)
(make-auto-pointer (foreign-string-alloc string)))
-(defun coerce-enum (enum)
+(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)
@@ -360,9 +391,15 @@
(object.typep 'string))
(make-match 'promotion 'coerce-c-string)))
(6 (when (object.typep 'enum)
- (make-match 'promotion 'coerce-enum)))
+ (make-match 'promotion 'coerce-from-enum)))
(7 (when (object.typep 'enum)
- (make-match 'promotion 'coerce-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)
@@ -374,7 +411,8 @@
(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)))
+ (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))
@@ -391,21 +429,24 @@
: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
+ ;; 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!.
+ ;; 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
+ :from (find-class 't)
+ :to (find-class 't)))) ;; FIXME get the class when applicable
(defun+using-type conversion object (object type)
@@ -417,20 +458,27 @@
(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)
- (format nil "operator ~A"
- (if (class-p type)
- (name (get-class type))
- (name type))))))
+ (conversion-operator-name type))))
(when (valid-p method)
- (assert (not (void-p type))
- ()
- "Conversion operators not supported by Smoke.
-Update to Smoke >= r955426.")
- (make-match 'user-conversion
- (lispify (name method) :cxx))))))
+ (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)
@@ -439,16 +487,21 @@
(defun+using-type constructor-conversion object (object type)
(when (class-p type)
- (let ((to-class (find-smoke-class (get-class type))))
- (when (call-using-types find-best-viable-function2
- (if (using-typep)
- #'standard-conversion-sequence-using-types
- #'standard-conversion-sequence)
- (format nil "~A" (name (get-class type)))
- (list object) to-class)
- (make-match 'user-conversion
- 'coerce-to-class
- to-class)))))
+ (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
@@ -459,7 +512,7 @@
(defun format-no-applicable-cxx-method (stream name class arguments)
(format stream
"No applicable method ~S of ~A for ~S.
-Candidtes are:~{~T~%~}."
+Candidates are:~{~T~A~%~}."
name class arguments
(mapcar #'signature
(viable-functions name
@@ -475,28 +528,78 @@
(condition-method condition)
(condition-class condition)
(condition-arguments condition)))))
-
+
(defun call-using-args (object-or-class name arguments)
- (declare (optimize (speed 3)))
- (if (null arguments)
- (let ((method (find-smoke-method (smoke-class-of object-or-class)
- name)))
- (assert (valid-p method)
- ()
- "No applicable method ~A() for ~A." name object-or-class)
- (if (static-p method)
- (s-call method (null-pointer))
- (s-call method (cast object-or-class (get-class method)))))
- (multiple-value-bind (method sequence)
- (find-best-viable-function name
- arguments
- (smoke-class-of object-or-class))
- (when (null method)
- (error (make-condition 'no-applicable-cxx-method
- :method name
- :class object-or-class
- :arguments arguments)))
- (if (static-p method)
- (apply #'call-sequence method (null-pointer) sequence arguments)
- (apply #'call-sequence method (cast object-or-class (get-class method))
- sequence 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-01 21:50:02.000000000 +0200
+++ new-smoke/src/package.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -13,29 +13,56 @@
(defpackage #:smoke
(:use #:cl #:cffi #:trivial-garbage #:bordeaux-threads #:cxx-support
#:alexandria)
- (:export #:init
- #:get-smoke-variable-for-pointer
-
- #:make-smoke-classes
- #:eval-startup
-
- #:new-object
- #:delete-object
- #:smoke-call
- #:call
+ (:export #:call
+ #:c-integer
- #:name
+ #:class-p
+ #:class-size
+ #:const-p
#:id
- #:smoke-type=
+ #:name
+ #:pointer
+ #:pointer-p
+ #:size
+ #:smoke
+ #:stack-p
+ #:type-foreign-keyword
+ #:type-id
+ #:type-size
+ #:virtual-destructor-p
+ #:convert-argument
#:cxx-bool
#:define-from-lisp-translation
- #:make-cleanup-pointer
+ #:define-to-lisp-translation
+ #:*to-lisp-translations*
- #:pointer
+ #:define-pointer-typedef
#:define-smoke-module
+
#:define-takes-ownership
+ #:delete-object
+ #:remove-object
+
+ #:eval-startup
+
+ #:get-smoke-variable-for-pointer
+ #:init
+ #:object-to-lisp
+
+ #:make-auto-pointer
+ #:make-cleanup-pointer
+
+ #:make-smoke-classes
+ #:make-smoke-type
+ #:no-applicable-cxx-method
+ #:smoke-call
+ #:upcast
+
+ #:smoke-standard-object
+ #:smoke-type
+ #:smoke-type=
#+sbcl #:save-bundle))
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-01 21:50:02.000000000 +0200
@@ -0,0 +1,159 @@
+(in-package :smoke)
+
+(declaim (optimize (debug 3)))
+
+(defmacro catch-try ((tag &optional catch-result) catch-form &body body)
+ "Catch TAG in the BODY forms. When TAG is throw CATCH-RESULT is bound
+to the thrown values and result of CATCH-FORM is returned. Otherwise
+the result of BODY is returned and CATCH-FORM is not evaluated."
+ (flet ((catch-block (tag return-block body)
+ `(catch ,tag
+ (return-from ,return-block
+ ,@body))))
+ (let ((return-block (gensym)))
+ `(block ,return-block
+ ,(if catch-result
+ `(let ((,catch-result ,(catch-block tag return-block body)))
+ ,catch-form)
+ `(progn ,(catch-block tag return-block body)
+ ,catch-form))))))
+
+(defun type-specifier (lvar)
+ (let ((type (sb-kernel:type-specifier (sb-c::lvar-type lvar))))
+ (if (subtypep type 'smoke-standard-object)
+ (find-class type)
+ type)))
+
+
+(defun give-up-transform (&rest args)
+ (apply #'sb-c::give-up-ir1-transform args))
+
+(defmacro define-transform (name lambda-list &body body)
+ `(sb-c:deftransform ,name (,lambda-list)
+ ,@body))
+
+(defmacro define-known (name)
+ `(sb-c:defknown ,name * *))
+
+(defun method-form (method)
+ `(make-smoke-method
+ :id ,(id method)
+ :smoke (eval ,(get-smoke-variable-for-pointer
+ (smoke method)))))
+
+(defun sequence-form (sequence arguments)
+ (mapcar #'(lambda (sequence argument)
+ (if (symbolp sequence)
+ `(,sequence ,argument)
+ `(,(first sequence) ,argument ,@(rest sequence))))
+ sequence arguments))
+
+
+(defmacro define-resolve-at-compile-time (gf-name)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (define-known ,gf-name)
+ (sb-c:defoptimizer (,gf-name derive-type) ((object &rest args))
+ (catch-try ('unspecific-type) sb-c::*wild-type*
+ (let ((method (find-best-viable-function-using-types
+ ,(name (fdefinition gf-name))
+ (mapcar #'type-specifier args) (type-specifier object))))
+ (if (and method (class-p (return-type method)))
+ (sb-kernel:single-value-specifier-type
+ (find-smoke-class (get-class (return-type method))))
+ sb-c::*wild-type*))))
+ (define-transform ,gf-name (object &rest args)
+ (when (null args)
+ (give-up-transform "No arguments."))
+ (catch-try ('unspecific-type reason)
+ (give-up-transform "Could not resolve overload at compile time: ~A" reason)
+ (multiple-value-bind (method sequence)
+ (find-best-viable-function-using-types
+ ,(name (fdefinition gf-name))
+ (mapcar #'type-specifier args)
+ (type-specifier object))
+ (let ((argument-names (make-gensym-list (length args))))
+ (when (null method)
+ (give-up-transform "No applicable method."))
+ (if (static-p method)
+ `(s-call ,(method-form method)
+ (null-pointer)
+ (list ,@(sequence-form
+ sequence args)))
+ `(lambda (object ,@argument-names)
+ (s-call ,(method-form method)
+ ,(if (eql (type-specifier object)
+ (find-smoke-class (get-class method)))
+ `(pointer object)
+ `(cast object
+ (find-class (quote ,(class-name
+ (find-smoke-class
+ (get-class method)))))))
+ (list ,@(sequence-form
+ sequence argument-names)))))))))))
+
+
+;;; Cache overload resolution / method lookup
+
+;;; FIXME the cached lookup should be faster
+;;;
+;;; cache return value conversion
+;;;
+;;; Using the gf symbol instead of the method name would be better,
+;;; althoug we would have to invent one for constructors.
+;;;
+;;; Since the -using-types stuff was intended for for compile time
+;;; expansion it is not that well suited for this. i.e. passing
+;;; closures would be better than the actual syntax.
+;;;
+;;; For qt.tests the uncached calls make up 30 % of all calls.
+;;; qt.examples:colliding-mice (run for ~1 min) gets 20 % uncached
+;;; calls and qt.examples:class-browser get 10 %. (20 February 2010)
+
+(sb-int:defun-cached (find-best-viable-function-using-layouts-cached
+ :hash-function (lambda (name arguments
+ class const-p)
+ (declare (string name)
+ (list arguments)
+ (sb-c::layout class)
+ (boolean const-p))
+ (logand
+ (logxor
+ (sxhash name)
+ (the fixnum
+ (reduce
+ #'logxor
+ (mapcar #'sb-c::layout-clos-hash
+ arguments)))
+ (sxhash class)
+ (sxhash const-p))
+ #x1FF))
+ :hash-bits 9)
+ ((name equal) (arguments equal) (class eq) (const-p eq))
+ (declare (optimize (speed 3))
+ (inline find-best-viable-function-using-types))
+ (multiple-value-bind (method conversion-sequence)
+ (find-best-viable-function-using-types
+ name (mapcar #'sb-pcl::wrapper-class* arguments)
+ class const-p)
+ (list method (mapcar #'(lambda (s)
+ (if (symbolp s)
+ (fdefinition s)
+ #'(lambda (x)
+ (declare (optimize (speed 3)))
+ (funcall (fdefinition (first s))
+ x
+ (eval (second s))))))
+ conversion-sequence))))
+
+(declaim (inline find-best-viable-function-cached))
+(defun find-best-viable-function-cached (name arguments class const-p)
+ (declare (optimize (speed 3)))
+ (catch 'unspecific-type
+ (return-from find-best-viable-function-cached
+ (values-list
+ (find-best-viable-function-using-layouts-cached
+ name
+ (mapcar #'(lambda (o) (sb-c::layout-of o)) arguments)
+ class
+ const-p))))
+ (find-best-viable-function name arguments class const-p))
diff -rN -u old-smoke/src/smoke-c/CMakeLists.txt new-smoke/src/smoke-c/CMakeLists.txt
--- old-smoke/src/smoke-c/CMakeLists.txt 2014-10-01 21:50:01.000000000 +0200
+++ new-smoke/src/smoke-c/CMakeLists.txt 1970-01-01 01:00:00.000000000 +0100
@@ -1,25 +0,0 @@
-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)
-
-set(SMOKE_C_SOURCES smoke-c.cpp csmokebinding.cpp)
-add_library(smoke-c MODULE ${SMOKE_C_SOURCES})
-set_target_properties(smoke-c
- PROPERTIES
- SOVERSION "0.0"
- VERSION "0.0.1")
-
-add_library(smoke-c-util MODULE smoke-c-util.cpp)
-set_target_properties(smoke-c-util
- PROPERTIES
- SOVERSION "0.0"
- VERSION "0.0.1")
-
-install(TARGETS smoke-c smoke-c-util
- LIBRARY DESTINATION lib)
diff -rN -u old-smoke/src/smoke-c/cl_smoke.h new-smoke/src/smoke-c/cl_smoke.h
--- old-smoke/src/smoke-c/cl_smoke.h 2014-10-01 21:50:02.000000000 +0200
+++ new-smoke/src/smoke-c/cl_smoke.h 1970-01-01 01:00:00.000000000 +0100
@@ -1,49 +0,0 @@
-#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 Common Lisp smoke binding namespace. */
-namespace cl_smoke
-{
-class Binding;
-
-/** 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
-
-#endif // CL_SMOKE_H
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-01 21:50:02.000000000 +0200
+++ new-smoke/src/smoke-c/class.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,49 +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-01 21:50:02.000000000 +0200
+++ new-smoke/src/smoke-c/csmokebinding.cpp 1970-01-01 01:00:00.000000000 +0100
@@ -1,87 +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 when a Smoke method gets called. */
-bool
-Binding::callMethod(Smoke::Index method, void* object,
- Smoke::Stack stack, bool abstract)
-{
- int ret = dispatch(this, method, object, stack, abstract);
- Q_ASSERT( !abstract || ret );
-
- return ret;
-}
-
-/**
- * @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-01 21:50:02.000000000 +0200
+++ 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-01 21:50:02.000000000 +0200
+++ new-smoke/src/smoke-c/method.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,74 +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))
-
-(defcstruct smoke-method-map
- "Maps a munged method."
- (class-id smoke-index)
- (name smoke-index)
- (method smoke-index))
-
-(defcfun smoke-get-method-map (:pointer smoke-method-map)
- (smoke :pointer)
- (index smoke-index))
-
-(defcfun smoke-find-method-for-id :void
- (m :pointer smoke-module-index)
- (smoke :pointer)
- (class-index smoke-index)
- (method-name 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 :void
- (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-01 21:50:01.000000000 +0200
+++ new-smoke/src/smoke-c/smoke-c-util.cpp 1970-01-01 01:00:00.000000000 +0100
@@ -1,27 +0,0 @@
-#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
-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-01 21:50:02.000000000 +0200
+++ new-smoke/src/smoke-c/smoke-c.cpp 1970-01-01 01:00:00.000000000 +0100
@@ -1,411 +0,0 @@
-#include "csmokebinding.h"
-#include "cl_smoke.h"
-
-#include <smoke.h>
-
-#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
- */
-
-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
- */
-CL_SMOKE_EXPORT 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.
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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.
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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.
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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.
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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;
-}
-
-/** Finds a method for a class and a munged name.
- * @param m pointer where the result is stored.
- * @param smoke the Smoke binding
- * @param class_index index of the class
- * @param method_name index of the munged method name
- */
-CL_SMOKE_EXPORT void
-smoke_find_method_for_id(Smoke::ModuleIndex* m, void* smoke,
- Smoke::Index class_index, Smoke::Index method_name)
-{
- *m = get_smoke(smoke)->findMethod((Smoke::ModuleIndex){get_smoke(smoke), class_index},
- (Smoke::ModuleIndex){get_smoke(smoke), 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
- */
-CL_SMOKE_EXPORT 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.
- */
-CL_SMOKE_EXPORT void
-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);
- }
- // This catch is mostly useless:
- // Qt / KDElibs do not use exceptions and since they are often built with -fno-exceptions
- // the catch will have no effect and the terminate handler is called instead.
- catch (const std::exception& e)
- {
- qFatal(e.what());
- }
- catch (...)
- {
- qFatal("exception in C++ code.");
- }
-}
-
-///////////////////////////
-/// Type
-//////////////////////////
-
-/** Gets the number of types.
- * @param smoke the Smoke module
- *
- * @return the number of types
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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
- */
-CL_SMOKE_EXPORT 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-01 21:50:02.000000000 +0200
+++ new-smoke/src/smoke-c/smoke-c.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,71 +0,0 @@
-(in-package #:smoke)
-
-;; Load the qt smoke binding to prevent undefined aliens.
-(eval-when (:load-toplevel :compile-toplevel :execute)
- (define-foreign-library libsmokeqt
- (:unix "libsmokeqt.so.2")
- (t (:default "libsmokeqt")))
- #-mudballs
- (define-foreign-library libsmoke-c
- (:unix "libsmoke-c.so")
- (t (:default "libsmoke-c")))
- #-mudballs
- (define-foreign-library libsmoke-c-util
- (:unix "libsmoke-c-util.so")
- (t (:default "libsmoke-c-util")))
-
- (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)))
- (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")
-
-(deftype smoke-index (&optional (lower -32768) (upper 32767))
- "Smoke index."
- `(integer ,lower ,upper))
-
-(defcfun smoke-init smoke-binding
- (smoke :pointer)
- (destruct :pointer)
- (dispatch :pointer))
-
-(defcfun smoke-destruct :void
- (smoke smoke-binding))
-
-(defcstruct smoke-module-index
- (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-01 21:50:01.000000000 +0200
+++ 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-01 21:50:02.000000000 +0200
+++ 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-01 21:50:02.000000000 +0200
@@ -0,0 +1,180 @@
+(in-package :smoke)
+
+(defun constant-definition (package method smoke)
+ "Returns an expression that defines a constant for the enum METHOD.
+The second return value is the expression to export the constant."
+ (let ((symbol
+ (if (or (string= (name (get-class method))
+ "Qt")
+ (string= (name (get-class method))
+ "QGlobalSpace"))
+ (lispify (concatenate 'string "+" (name method)
+ "+")
+ package)
+ (lispify (concatenate 'string
+ (name (get-class method))
+ ".+"
+ (name method) "+")
+ package))))
+ (values
+ (if (= 8 (type-id (return-type method)))
+ `(define-constant ,symbol ;; a long, not really an enum.
+ ,(enum-call method))
+ `(define-constant ,symbol
+ (make-instance 'enum
+ :value ,(enum-call method)
+ :type (make-instance 'smoke-type
+ :id ,(id (return-type method))
+ :smoke ,smoke))
+ :test #'enum=))
+ symbol)))
+
+(defun static-method-symbol (package method)
+ "Returns the lisp symbol for the static method METHOD."
+ (let ((class (get-class method)))
+ (lispify (concatenate 'string
+ (if (string= (name class)
+ "QGlobalSpace")
+ nil
+ (concatenate 'string
+ (name class)
+ "."))
+ (name method))
+ package)))
+
+(defun static-method-definition (package method &optional (argument-count -1))
+ "Returns an expression to define a function for the static METHOD.
+The second return value is the expression to export the function."
+ (let* ((class (get-class method))
+ (method-name (name method))
+ (name (static-method-symbol package method)))
+ (values
+ `(defun ,name ,(if (< argument-count 0)
+ '(&rest args)
+ (make-lambda argument-count))
+ (call-using-args
+ (find-class (quote ,(lispify (name class)
+ (if (string= (name class)
+ "QGlobalSpace")
+ *package* ;; See #'MAKE-SMOKE-CLASSES
+ package))))
+ ,method-name
+ ,(if (< argument-count 0)
+ 'args
+ `(list ,@(make-lambda argument-count)))))
+ name)))
+
+(defun ensure-generic-methods (symbols-names)
+ "Ensures the generic functions for SYMBOLS-NAMES."
+ (declare (list symbols-names)
+ (optimize (speed 3)))
+ (dolist (symbol-name symbols-names)
+ (ensure-generic-function (first symbol-name)
+ :cxx-name (rest symbol-name)
+ :generic-function-class 'smoke-gf
+ :lambda-list '(object &rest args))
+ (export (first symbol-name) :cxx)))
+
+(defun setf-method-definition (method)
+ `(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)
+ (,(lispify (name method) :cxx) object new-value)
+ new-value))
+
+(defmacro sizes= ((smoke)&rest arrays)
+ `(and ,@(loop for array in arrays collect
+ `(= (smoke-array-length (,array ,smoke))
+ ,(smoke-array-length (funcall (fdefinition array)
+ (eval smoke)))))))
+
+(defmacro check-recompile (smoke)
+ "Raises an error or tries to recompile when the fasl of the define-classes-and-gfs
+was not compiled against the current smoke module."
+ (with-unique-names (restart)
+ `(eval-when (:load-toplevel :execute)
+ (unless (sizes= (,smoke)
+ smoke-module-methods
+ smoke-module-method-names
+ smoke-module-method-maps
+ smoke-module-classes
+ smoke-module-types)
+ (let ((,restart (find-restart 'asdf:try-recompiling)))
+ (if ,restart
+ (invoke-restart ,restart)
+ (error "The smoke module ~A changed, you need to recompile the lisp file."
+ (smoke-get-module-name (smoke-module-pointer ,smoke)))))))))
+
+(defmacro define-classes-and-gfs (package smoke)
+ "Process the C++ methods of the Smoke module SMOKE.
+Expands to DEFUNs for static methods, DEFINE-CONSTANTs for enum methods
+and a function do define the generic methods a load-time."
+;;; symbol - id pairs are stored in the hash-tables to prevent the
+;;; multiple definition of a function with the same name.
+ (let ((generics (make-hash-table))
+ (constants)
+ (functions)
+ (function-symbols (make-hash-table))
+ (setf-function-symbols (make-hash-table))
+ (exports))
+ (map-methods
+ #'(lambda (method)
+ (when (and (enum-p method)
+ ;; qt.network has QIODevice::NotOpen(), but the
+ ;; class is external (workaround).
+ (not (external-p (get-class method))))
+ (multiple-value-bind (def export) (constant-definition package method smoke)
+ (push def
+ constants)
+ (push export exports)))
+ (when (and (not (destructor-p method))
+ (not (constructor-p method))
+ (not (enum-p method))
+ (not (eql nil (name method)))
+ (string/= (name method) "tr")) ;; we have a custom qt:tr function
+ (let ((name (name method)))
+ (when (and (starts-with-subseq "set" name)
+ (> (length name) 3)
+ (upper-case-p (char name 3))
+ (= 1 (get-arguments-length method)))
+ (unless (nth-value 1 (gethash (lispify name :cxx) setf-function-symbols))
+ (setf (gethash (lispify name :cxx) setf-function-symbols) t)
+ (push (setf-method-definition method) functions)))
+ (let ((lisp-name (lispify name "CXX")))
+ (unless (and (gethash lisp-name generics) (attribute-p method))
+ (setf (gethash lisp-name generics) name))))
+ (when (static-p method)
+ (let* ((function-symbol (static-method-symbol package method))
+ (methods (gethash function-symbol function-symbols)))
+ (unless (fboundp function-symbol) ;; do not overwrite
+ ;; existing functions e.g. qInstallMsgHandler of
+ ;; qt.core with that of qt.gui which causes a
+ ;; segfault when loading from an saved image.
+ (setf (gethash function-symbol function-symbols)
+ (if methods (- (id method)) (id method))))))))
+ (eval smoke))
+ (loop for id being the hash-values of function-symbols do
+ (let ((method (make-smoke-method
+ :smoke (eval smoke)
+ :id (abs id))))
+ (multiple-value-bind (definition export)
+ (static-method-definition
+ package
+ method
+ (if (< 0 id)
+ (get-arguments-length method)
+ -1))
+ (push definition functions)
+ (push export exports))))
+ `(progn (check-recompile ,smoke)
+ ,@functions
+ (eval-startup (:compile-toplevel :load-toplevel :execute)
+ ;; FIXME when loading the Lisp image we no longer need
+ ;; to call #'ensure-class, but the class-map needs still
+ ;; to be populated by #'add-id-class-map and #'add-id;
+ ;; For now we ignore the negligible overhead.
+ (make-smoke-classes ,package ,smoke))
+ (eval-when (:load-toplevel :execute)
+ (ensure-generic-methods ',(hash-table-alist generics)))
+ ,@constants
+ (eval-when (:load-toplevel :execute)
+ (export (quote ,exports) ,package)))))
+
diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp
--- old-smoke/src/smoke.lisp 2014-10-01 21:50:02.000000000 +0200
+++ new-smoke/src/smoke.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -1,4 +1,4 @@
-;;; Copyright (C) 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
+;;; 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
@@ -27,162 +27,175 @@
(in-package #:smoke)
-(defun s-call (method object &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))))
+(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 pointer-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))
- (foreign-slot-value (pointer stack) 'smoke-stack-item 'class)))
+ (call-s-method method object-pointer (call-stack-pointer stack))
+ (type-to-lisp (call-stack-pointer stack) (return-type method))))
+(defun pointer-call (method object-pointer &optional (args nil))
+ (with-stack (stack args (arguments method) )
+ (call-s-method method object-pointer (call-stack-pointer stack))
+ (foreign-slot-value (call-stack-pointer stack) 'smoke-stack-item 'class)))
(defun smoke-call (class pointer method-name &optional (args nil))
- (s-call
- (make-smoke-method 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))
- (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 (class-of object)))))
- (s-call
- (make-smoke-method (class-of 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 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)
+(defun init (smoke module)
"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))
+ (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 (eval symbol)) pointer-symbol-map)
+ (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."
- `(progn
- (eval-startup (:compile-toplevel :execute)
+ (let ((smoke-module (intern "*SMOKE-MODULE*")))
+ `(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-foreign-library ,library
- (:unix ,(format nil "~(~A~).so.2" library))
- (t (:default ,(format nil "~(~A~)" library))))
- (use-foreign-library ,library))
- (defcvar (,variable ,variable-name :read-only t) :pointer)
- (defcfun (,init-function ,(format nil "_Z~A~Av" (length function-name)
- function-name))
- :void))
- (eval-startup (:compile-toplevel :execute)
- (,init-function)
- (init ,variable))
- (define-classes-and-gfs ,package ,variable)))
+ (: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))
@@ -193,6 +206,10 @@
"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-01 21:50:01.000000000 +0200
+++ new-smoke/src/translate.lisp 1970-01-01 01:00:00.000000000 +0100
@@ -1,27 +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)
- (declare (ignore smoke-class))
- (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 2014-10-01 21:50:01.000000000 +0200
+++ new-smoke/src/using-type.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -1,3 +1,5 @@
+;;; NOTE -using-type is disabled for now, since it is not used.
+
(in-package :smoke)
(defmacro with-object-as-object (object &body body)
@@ -11,12 +13,11 @@
`(,function-name ,@args))
(call-using-type (function-name &rest args)
`(,function-name ,@args)))
- ,@body))
+ ,@body))
(defun typep-using-type (object-type type)
"Returns true when OBJECT-TYPE is a subtype of TYPE,
-false when it is not"; and :MAYBE when the relationship
-;could not be determined."
+false when it is not."
(declare (values (member t nil :maybe)))
(multiple-value-bind (subtype-p valid-p)
(subtypep object-type type)
@@ -28,7 +29,10 @@
(if subtype-p
(throw 'unspecific-type (values object-type type))
(if valid-p
- nil
+ (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))))))
@@ -80,3 +84,8 @@
`(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/impl/ccl.lisp new-smoke/src/utils/image/impl/ccl.lisp
--- old-smoke/src/utils/image/impl/ccl.lisp 2014-10-01 21:50:01.000000000 +0200
+++ new-smoke/src/utils/image/impl/ccl.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -2,3 +2,10 @@
(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 2014-10-01 21:50:01.000000000 +0200
+++ new-smoke/src/utils/image/impl/sbcl.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -11,3 +11,10 @@
(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 2014-10-01 21:50:01.000000000 +0200
+++ new-smoke/src/utils/sbcl-bundle.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -18,7 +18,7 @@
(sb-ext:run-program "/bin/rm"
(list "-r" (namestring ,directory)))))
(cerror "ignore"
- "could not remove temponary directory ~A"
+ "could not remove temporary directory ~A"
,directory)))))
(defun save-image (file-name &rest options &key &allow-other-keys)
diff -rN -u old-smoke/test-bundle.sh new-smoke/test-bundle.sh
--- old-smoke/test-bundle.sh 2014-10-01 21:50:01.000000000 +0200
+++ new-smoke/test-bundle.sh 2014-10-01 21:50:02.000000000 +0200
@@ -5,8 +5,8 @@
exit 1
fi
-sbcl --eval '(mb:load :qt.tests)' \
+MALLOC_CHECK_=3 sbcl --eval '(require :cl-smoke.qt.tests)' \
--eval '(smoke:save-bundle "qt.test.run")' \
--eval '(quit)' || exit 1
-echo "(progn (5am:run!) (quit))" | ./qt.test.run
+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-01 21:50:01.000000000 +0200
+++ new-smoke/test.lisp 2014-10-01 21:50:02.000000000 +0200
@@ -1,27 +1,28 @@
#|
-sbcl --noinform --noprint --disable-debugger --load $0 --end-toplevel-options "$@" || exit 1
-sh ./test-bundle.sh || exit 2
+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
-# do not use --script to allow loading mudballs with ${HOME}/.sbclrc
# 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)