Thu May 14 14:07:00 CEST 2009  Tobias Rautenkranz <tobias@rautenkranz.ch>
  * Dump Lisp image & make bundle with C wrapper libraries.
diff -rN -u old-smoke/smoke.mbd new-smoke/smoke.mbd
--- old-smoke/smoke.mbd	2014-10-01 11:42:51.000000000 +0200
+++ new-smoke/smoke.mbd	2014-10-01 11:42:52.000000000 +0200
@@ -31,7 +31,6 @@
    (:src module
          (:needs "CMakeLists")
          (:components
-          ("CMakeLists.txt" static-file)
           "package"
           ("translate" (:needs "package"))
           ("using-type" (:needs "package"))
@@ -53,12 +52,6 @@
                     (:components ("libsmoke-c" cmake-library)
                                  ("libsmoke-c-util" cmake-library)
 
-                                 ;; Make release-action add this files
-                                 ("CMakeLists.txt" static-file)
-                                 ("csmokebinding.h" static-file)
-                                 ("csmokebinding.cpp" static-file)
-                                 ("smoke-c.cpp" static-file)
-
                                  ("smoke-c" (:needs "libsmoke-c"
                                                     "libsmoke-c-util"))
                                  ("class" (:needs "smoke-c"))
@@ -68,7 +61,10 @@
 
           (:utils module
                   (:needs "package")
-                  (:components "get-value")))))
+                  (:requires (:sb-posix (:for :sbcl)))
+                  (:components "get-value"
+                               ("image" (:for (:not :sbcl)))
+                               ("image-sbcl" (:for :sbcl)))))))
   (:needs :sysdef.cmake :cffi :closer-mop
           :alexandria
           :trivial-garbage :bordeaux-threads))
diff -rN -u old-smoke/src/class-map.lisp new-smoke/src/class-map.lisp
--- old-smoke/src/class-map.lisp	2014-10-01 11:42:51.000000000 +0200
+++ new-smoke/src/class-map.lisp	2014-10-01 11:42:52.000000000 +0200
@@ -5,17 +5,28 @@
   "Maps a Smoke module pointer - id pair to a class.")
 ;; FIXME disallow adding a class when threads are running or add a lock.
 
-(defmacro id-class-map (smoke)
-  `(gethash (pointer-address ,smoke)
-            *smoke-id-class-map*))
+
+(defun id-class-map (smoke)
+  (let ((value (gethash (pointer-address smoke)
+                        *smoke-id-class-map*)))
+    (assert value 
+            ()
+            "Unknown smoke module ~A ~A."
+            smoke (smoke-get-module-name smoke))
+    value))
+
+(defun (setf id-class-map) (new-value smoke)
+  (setf (gethash (pointer-address smoke) *smoke-id-class-map*)
+        new-value))
 
 (defun add-id-class-map (smoke)
-  (unless (nth-value 1 (id-class-map smoke))
-    (setf (id-class-map smoke)
-          (make-hash-table))))
+  (setf (id-class-map smoke)
+        (make-hash-table)))
 
 (defun add-id (smoke-class class)
   "Associates the CLOS class CLASS with SMOKE-CLASS."
+  (declare (smoke-class smoke-class)
+           (smoke-standard-class class))
   (setf (gethash (id smoke-class)
         (id-class-map (smoke smoke-class)))
         class))
diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp
--- old-smoke/src/clos.lisp	2014-10-01 11:42:51.000000000 +0200
+++ new-smoke/src/clos.lisp	2014-10-01 11:42:52.000000000 +0200
@@ -133,7 +133,11 @@
   (:documentation "A Smoke C++ class"))
 
 (defclass smoke-wrapper-class (smoke-standard-class)
-  ())
+  ((smoke :reader smoke-symbol :initarg :smoke-symbol
+         :type symbol)))
+
+(defmethod smoke ((class smoke-wrapper-class))
+  (eval (smoke-symbol class)))
 
 (defclass cxx:class (smoke-wrapper-class)
   ()
@@ -178,7 +182,7 @@
     (apply
      #'call-next-method class
      :id (id superclass)
-     :smoke (smoke superclass)
+     :smoke (get-smoke-variable-for-pointer (smoke superclass))
      :direct-superclasses direct-superclasses
      args)))
 
@@ -195,7 +199,7 @@
     (apply
      #'call-next-method class
      :id (id superclass)
-     :smoke (smoke superclass)
+     :smoke (get-smoke-variable-for-pointer (smoke superclass))
      :direct-superclasses direct-superclasses
      args)))
 
@@ -207,8 +211,8 @@
 
 (defun make-smoke-classes (smoke)
   "Construts a lisp class for each one in the Smoke module SMOKE."
-  (declare (optimize (speed 3))
-           (cffi:foreign-pointer smoke))
+  (declare (foreign-pointer smoke)
+           (optimize (speed 3)))
   (add-id-class-map smoke)
     (map-classes 
      #'(lambda (class)
diff -rN -u old-smoke/src/cxx-method.lisp new-smoke/src/cxx-method.lisp
--- old-smoke/src/cxx-method.lisp	2014-10-01 11:42:51.000000000 +0200
+++ new-smoke/src/cxx-method.lisp	2014-10-01 11:42:52.000000000 +0200
@@ -86,7 +86,7 @@
   "Removes METHOD from its generic-function."
   (let ((generic-function (closer-mop:method-generic-function method)))
     (when generic-function
-      (remove-method (closer-mop:method-generic-function) method))))
+      (remove-method generic-function method))))
     ;(when (null (closer-mop:generic-function-methods generic-function))
     ;  TODO
                  
diff -rN -u old-smoke/src/method.lisp new-smoke/src/method.lisp
--- old-smoke/src/method.lisp	2014-10-01 11:42:51.000000000 +0200
+++ new-smoke/src/method.lisp	2014-10-01 11:42:52.000000000 +0200
@@ -17,11 +17,11 @@
      `(define-constant ,symbol
         (make-instance 'enum
                        :value ,(enum-call method)
-                       :type (make-instance 'smoke-type
+                       :type (make-instance 'smoke-lazy-type
                                             :id ,(id (return-type method))
-                                            :smoke ,smoke))
+                                            :smoke ',smoke))
         :test #'enum=)
-     `(export (quote ,symbol)))))
+     symbol)))
 
 (defun static-method-symbol (method)
   "Returns the lisp symbol for the static method METHOD."
@@ -50,18 +50,15 @@
                          ,(if (< argument-count 0)
                               'args
                               `(list ,@(make-lambda argument-count)))))
-     `(export (quote ,name)))))
+     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)
+(defun generic-method-definition (name cxx-name)
+  (values 
+   `(ensure-generic-function (quote ,name)
+                             :cxx-name ,cxx-name
                              :generic-function-class 'smoke-gf
                              :lambda-list '(object &rest args))
-    (export (first symbol-name) :CXX)))
+   name))
 
 (defun setf-method-definition (method)
   `(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)
@@ -92,8 +89,10 @@
   (let ((generics (make-hash-table))
         (constants)
         (functions)
+        (ensure-generics)
         (function-symbols (make-hash-table))
         (setf-function-symbols (make-hash-table))
+        (cxx-exports)
         (exports))
     (map-methods 
      #'(lambda (method)
@@ -139,12 +138,20 @@
                     -1))
              (push definition functions)
              (push export exports))))
+    (loop for name being the hash-key of generics
+       for cxx-name being the hash-value of generics do
+       (multiple-value-bind (definition export)
+           (generic-method-definition name cxx-name)
+         (push definition ensure-generics)
+         (push export cxx-exports)))
     `(progn (check-recompile ,smoke)
             ,@functions
-            (eval-when (:load-toplevel :execute)
+            (eval-startup (:execute)
               (register-smoke-module-var (quote ,smoke))
-              (ensure-generic-methods ',(hash-table-alist generics))
               (make-smoke-classes ,smoke))
+            (eval-when (:load-toplevel :execute)
+              ,@ensure-generics)
+            (export (quote ,cxx-exports) :cxx)
             ,@constants
-            ,@exports)))
+            (export (quote ,exports)))))
 
diff -rN -u old-smoke/src/objects/class.lisp new-smoke/src/objects/class.lisp
--- old-smoke/src/objects/class.lisp	2014-10-01 11:42:51.000000000 +0200
+++ new-smoke/src/objects/class.lisp	2014-10-01 11:42:52.000000000 +0200
@@ -25,10 +25,13 @@
 
 (defun map-classes (function smoke)
   "Applys 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- (smoke-classes-size smoke)) do
+                              :id 0
+                              :smoke smoke)))
+    (loop for id from 1 to (1- (the fixnum (smoke-classes-size smoke))) do
          (setf (slot-value class 'id) id)
          (funcall function class))))
 
diff -rN -u old-smoke/src/objects/enum.lisp new-smoke/src/objects/enum.lisp
--- old-smoke/src/objects/enum.lisp	2014-10-01 11:42:51.000000000 +0200
+++ new-smoke/src/objects/enum.lisp	2014-10-01 11:42:52.000000000 +0200
@@ -20,9 +20,9 @@
   (declare (ignore environment))
   `(make-instance 'enum
                   :value ,(value enum)
-                  :type (make-instance 'smoke::smoke-type
+                  :type (make-instance 'smoke::smoke-lazy-type
                                        :id ,(id (enum-type enum))
-                                       :smoke ,(smoke::get-smoke-variable-for-pointer
+                                       :smoke ',(smoke::get-smoke-variable-for-pointer
                                                 (smoke::smoke (enum-type enum))))))
 
 (defmethod print-object ((enum enum) stream)
diff -rN -u old-smoke/src/objects/type.lisp new-smoke/src/objects/type.lisp
--- old-smoke/src/objects/type.lisp	2014-10-01 11:42:51.000000000 +0200
+++ new-smoke/src/objects/type.lisp	2014-10-01 11:42:52.000000000 +0200
@@ -4,6 +4,14 @@
   ()
   (:documentation "A type"))
 
+(defclass smoke-lazy-type (smoke::smoke-type)
+  ((id :reader smoke::id
+       :initarg :id)
+   (smoke :initarg :smoke
+          :reader smoke-symbol)))
+
+(defmethod smoke::smoke ((type smoke-lazy-type))
+  (eval (smoke-symbol type)))
 
 (defmethod get-struct-slot-value ((type smoke-type) slot-name)
   (foreign-slot-value (smoke-get-type (smoke type) (id type))
diff -rN -u old-smoke/src/package.lisp new-smoke/src/package.lisp
--- old-smoke/src/package.lisp	2014-10-01 11:42:51.000000000 +0200
+++ new-smoke/src/package.lisp	2014-10-01 11:42:52.000000000 +0200
@@ -16,6 +16,7 @@
            #:get-smoke-variable-for-pointer
 
            #:make-smoke-classes
+           #:eval-startup
            
            #:new-object
            #:delete-object
@@ -33,7 +34,10 @@
            #:define-from-lisp-translation
            #:make-cleanup-pointer
 
-           #:pointer))
+           #:pointer
+           #:define-smoke-module
+
+           #+sbcl #:save-bundle))
 
 (defpackage #:cxx
   (:use) ;; do not use #:cl
@@ -53,7 +57,3 @@
            #:1-
            
            #:aref))
-
-
-
-(in-package #:smoke)
diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp
--- old-smoke/src/smoke.lisp	2014-10-01 11:42:51.000000000 +0200
+++ new-smoke/src/smoke.lisp	2014-10-01 11:42:52.000000000 +0200
@@ -161,6 +161,25 @@
                                (signature method))))
                smoke))
 
+(defmacro define-smoke-module (library (variable variable-name)
+                               (init-function function-name))
+  "Define a Smoke module."
+  `(progn
+     (eval-startup (:compile-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-methods ,variable)))
+         
+
 (defun fgrep-classes (smoke str)
   (map-classes #'(lambda (class)
                    (when (search str (name class))
diff -rN -u old-smoke/src/utils/image-sbcl.lisp new-smoke/src/utils/image-sbcl.lisp
--- old-smoke/src/utils/image-sbcl.lisp	1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/utils/image-sbcl.lisp	2014-10-01 11:42:52.000000000 +0200
@@ -0,0 +1,131 @@
+(in-package :smoke)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *startup-functions* nil
+    "Functions to run (in order) on startup.")
+
+  (defun add-startup-function (function)
+    (setf *startup-functions*
+          (nconc *startup-functions* (list function))))
+
+  (defun add-and-run-startup-function (function)
+    (add-startup-function function)
+    (funcall function))
+
+  (defun run-startup-functions ()
+    (mapcar #'funcall *startup-functions*)))
+
+(eval-when (:load-toplevel :execute)
+  (push #'run-startup-functions sb-ext:*init-hooks*))
+
+(defmacro eval-startup ((&rest situations) &body body)
+  "Runs BODY when it is loaded."
+  `(eval-when (,@situations :load-toplevel)
+     (add-and-run-startup-function #'(lambda ()
+                                       (let ((*package* ,*package*))
+                                         ,@body)))))
+
+(defun strip-foreign-libraries-path ()
+  (dolist (library sb-alien::*shared-objects*)
+    (setf (slot-value library 'namestring)
+          (file-namestring (slot-value library 'pathname)))))
+
+(defun make-temporary-directory ()
+  (pathname (concatenate 'string (sb-posix:mkdtemp "/tmp/cl-smokeXXXXXX")
+                         "/")))
+
+(defmacro with-temporary-directory ((directory) &body body)
+  "Binds DIRECTORY to the pathname of a temporary directory and executes body:"
+  `(let ((,directory (make-temporary-directory)))
+     (unwind-protect (progn ,@body)
+       (unless (zerop
+                (sb-ext:process-exit-code
+                 (sb-ext:run-program "/bin/rm"
+                                     (list "-r" (namestring ,directory)))))
+         (cerror "ignore"
+                 "could not remove temponary directory ~A"
+                 ,directory)))))
+  
+(defun save-image (file-name &rest options &key &allow-other-keys)
+  "Save the lisp image in FILE-NAME."
+  (let ((pid (sb-posix:fork)))
+    (if (= 0 pid)
+        (progn
+          (strip-foreign-libraries-path)
+          (apply #'sb-ext:save-lisp-and-die file-name :executable t
+                 options))
+        (sb-posix:waitpid pid 0))))
+
+(defun write-shell-wrapper (pathname core-name)
+  (with-open-file (stream pathname :direction :output)
+   (format stream "#!/bin/sh
+cd `dirname \"$0\"`
+LD_LIBRARY_PATH=./ exec -a \"$0\" ./~A $@
+" core-name))
+  (sb-posix:chmod pathname #o0755))
+
+(defun make-tarball (run-directory tarball-pathname &rest pathnames)
+  (flet ((arguments (&rest args)
+           (format nil "~{~A ~}" args)))
+    (unless (zerop
+             (sb-ext:process-exit-code
+              (sb-ext:run-program
+               "/bin/sh"
+               (list "-c"
+                     (apply #'arguments
+                            "cd " (namestring run-directory) " && "
+                            "tar -cvjf " (namestring tarball-pathname)
+                            " --strip 2 "
+                            (mapcar #'namestring pathnames))))))
+      (error "Create tarball ~A failed." tarball-pathname))))
+
+(defun makeself (run-directory directory-name file-name label 
+                 &optional (startup-script "") &rest args)
+  "Make self-extractable archives on Unix
+http://megastep.org/makeself/"
+  ;; make an absolute pathname sine we change the directory.
+  (let ((file-name (merge-pathnames file-name)))
+    (flet ((arguments (&rest args)
+             (format nil "~{~A ~}" args)))
+      (unless (zerop
+               (sb-ext:process-exit-code
+                (sb-ext:run-program
+                 "/bin/sh"
+                 (list "-c"
+                       (apply #'arguments
+                              "cd " (namestring run-directory) " && "
+                              "makeself --nox11" (namestring directory-name)
+                              (namestring file-name) label
+                              startup-script args)))))
+        (error "Create ~A failed." file-name)))))
+
+(defun save-bundle (file-name &optional extra-files &rest options &key &allow-other-keys)
+  "Creates a FILE-NAME.tar.bz2 in the current directory.
+This bundle contains a dumped image, the wrapper libraries and a
+script to run in. OPTIONS is passed to SB-EXT:SAVE-LISP-AND-DIE."
+  (with-temporary-directory (dir)
+    (let ((bundle-dir (merge-pathnames (make-pathname :directory
+                                                      (list :relative file-name))
+                                       dir)))
+      (sb-posix:mkdir bundle-dir #o0755)
+      (dolist (library sb-alien::*shared-objects*)
+        (sb-ext:run-program
+         "/bin/cp" (list (namestring (slot-value library 'pathname))
+                         (namestring bundle-dir))))
+      (apply #'save-image (namestring (make-pathname :name "sbcl-core"
+                                             :defaults bundle-dir))
+                  options)
+      (write-shell-wrapper (make-pathname :defaults bundle-dir
+                                          :name "run"
+                                          :type "sh")
+                           "sbcl-core")
+;;      (make-tarball dir (concatenate 'string file-name ".tar.bz2")
+;;                    file-name)
+      (dolist (file extra-files)
+        (copy-file file (merge-pathnames bundle-dir file)))
+      (makeself dir bundle-dir file-name "sbcl-bundle"
+                "./run.sh"))))
+;;      (copy-file (make-pathname :defaults dir
+;;                                :name (concatenate 'string file-name ".tar")
+;;                                :type "bz2")
+;                 (concatenate 'string file-name ".tar.bz2")))))
diff -rN -u old-smoke/src/utils/image.lisp new-smoke/src/utils/image.lisp
--- old-smoke/src/utils/image.lisp	1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/src/utils/image.lisp	2014-10-01 11:42:52.000000000 +0200
@@ -0,0 +1,6 @@
+(in-package :smoke)
+
+(defmacro eval-startup ((&rest situations) &body body)
+  "Runs BODY when it is loaded."
+  `(eval-when (,@situations :load-toplevel)
+     ,@body))
diff -rN -u old-smoke/test-bundle.sh new-smoke/test-bundle.sh
--- old-smoke/test-bundle.sh	1970-01-01 01:00:00.000000000 +0100
+++ new-smoke/test-bundle.sh	2014-10-01 11:42:51.000000000 +0200
@@ -0,0 +1,12 @@
+#!/bin/sh
+if [[ $# -ne 0 ]]; then
+	echo "Test cl-smoke bundle creation."
+	echo "Usage: $0"
+	exit 1
+fi
+
+sbcl --eval '(mb:load :qt.tests)' \
+	--eval '(smoke:save-bundle "qt.test.run")' \
+	--eval '(quit)' || exit 1
+
+echo "(progn (5am:run!) (quit))" | ./qt.test.run 
diff -rN -u old-smoke/test.lisp new-smoke/test.lisp
--- old-smoke/test.lisp	2014-10-01 11:42:51.000000000 +0200
+++ new-smoke/test.lisp	2014-10-01 11:42:52.000000000 +0200
@@ -1,5 +1,7 @@
 #|
-exec -a "$0" sbcl --noinform --noprint --disable-debugger --load $0 --end-toplevel-options "$@"
+sbcl --noinform --noprint --disable-debugger --load $0 --end-toplevel-options "$@" || exit 1
+sh ./test-bundle.sh || exit 2
+exit 0
 # do not use --script to allow loading mudballs with ${HOME}/.sbclrc
 # Used for testing on darcs record.
 |#