Build clfswm image in load.lisp. Let bind-on-slot on other child than current child

diff --git a/doc/dot-clfswmrc b/doc/dot-clfswmrc
index ce51b72..7dc7adb 100644 (file)
--- a/doc/dot-clfswmrc
+++ b/doc/dot-clfswmrc
@@ -190,3 +190,16 @@
 ;;;;                                             my-init-hook-rox-filer
 ;;;;(setf *init-hook* nil)
 ;;;;; Init hook end
+
+
+;;; For debuging: start another sever (for example: 'startx -- :1'), Xnest
+;;; or Zephyr and add the lines above in a dot-clfswmrc-debug file
+;;; mod-2 is the numlock key on some keyboards.
+;;(setf *default-modifiers* '(:mod-2))
+;;
+;;(defun my-add-escape ()
+;;  (define-main-key ("Escape" :mod-2) 'exit-clfswm))
+;;
+;;(add-hook *binding-hook* 'my-add-escape)
+;;
+;;(clfswm:main :display ":1" :alternate-conf #P"/where/is/dot-clfswmrc-debug")

diff --git a/load.lisp b/load.lisp
index 826997d..ca9d1d0 100644 (file)
--- a/load.lisp
+++ b/load.lisp
@@ -23,6 +23,9 @@
 ;;;
 ;;; --------------------------------------------------------------------------
 
+;;;------------------
+;;; Customization part
+;;;------------------
 (pushnew :clfswm-build *features*)
 (pushnew :clfswm-dump *features*)
 (pushnew :clfswm-start *features*)
@@ -31,21 +34,29 @@
 ;;;;;; Uncomment lines above to build the default documentation.
 ;;(pushnew :clfswm-build-doc *features*)
 
+;;;;; Uncomment the line below if you want to see all ignored X errors
+;;(pushnew :xlib-debug *features*)
+
+;;;;; Uncomment the line below if you want to see all event debug messages
+;;(pushnew :event-debug *features*)
+
 
 (defparameter *base-dir* (directory-namestring *load-truename*))
 (export '*base-dir*)
 
 
-#+CMU
+#+:CMU
 (setf ext:*gc-verbose* nil)
 
-
+;;;------------------
+;;; ASDF part
+;;;------------------
 ;;;; Loading ASDF
-#+(or SBCL ECL)
+#+(or :SBCL :ECL)
 (require :asdf)
 
 
-#-ASDF
+#-:ASDF
 (load (make-pathname :host (pathname-host *base-dir*)
                     :device (pathname-device *base-dir*)
                     :directory (append (pathname-directory *base-dir*) (list "contrib"))
@@ -53,54 +64,48 @@
 
 (push *base-dir* asdf:*central-registry*)
 
+;;(setf asdf:*verbose-out* t)
 
 
-
-
-#+(or CMU ECL)
+;;;------------------
+;;; XLib part
+;;;------------------
+#+(or :CMU :ECL)
 (require :clx)
 
-#+(AND CLISP (not CLX))
-(when (fboundp 'require)
-  (require "clx.lisp"))
-
-#-ASDF
-(load (make-pathname :host (pathname-host *base-dir*)
-                    :device (pathname-device *base-dir*)
-                    :directory (append (pathname-directory *base-dir*) (list "contrib"))
-                    :name "asdf" :type "lisp"))
-
-(push *base-dir* asdf:*central-registry*)
-
-;;(setf asdf:*verbose-out* t)
 
-;;;; Uncomment the line above if you want to follow the
-;;;; handle event mecanism.
-;;(pushnew :event-debug *features*)
+;;; This part needs clisp >= 2.50
+;;#+(AND CLISP (not CLX))
+;;(when (fboundp 'require)
+;;  (require "clx.lisp"))
 
+;;;------------------
+;;; CLFSWM loading
+;;;------------------
+#+:clfswm-build
 (asdf:oos 'asdf:load-op :clfswm)
 
+
+;;;-------------------------
+;;; Starting clfswm
+;;;-------------------------
 (in-package :clfswm)
 
-#-:clfswm-build-doc
+#+:clfswm-start
 (ignore-errors
-  (main :read-conf-file-p t))
+  (main :read-conf-file-p #-:clfswm-build-doc t #+:clfswm-build-doc nil))
+
 
 
+;;;-------------------------
+;;; Building documentation
+;;;-------------------------
 #+:clfswm-build-doc
-(ignore-errors
-  (main :read-conf-file-p nil)
-  (produce-all-docs))
-
-
-;;; For debuging: start another sever (for example: 'startx -- :1'), Xnest
-;;; or Zephyr and add the lines above in a dot-clfswmrc-debug file
-;;; mod-2 is the numlock key on some keyboards.
-;;(setf *default-modifiers* '(:mod-2))
-;;
-;;(defun my-add-escape ()
-;;  (define-main-key ("Escape" :mod-2) 'exit-clfswm))
-;;
-;;(add-hook *binding-hook* 'my-add-escape)
-;;
-;;(clfswm:main :display ":1" :alternate-conf #P"/where/is/dot-clfswmrc-debug")
+(produce-all-docs)
+
+;;;-----------------------
+;;; Building image part
+;;;-----------------------
+#+:clfswm-build
+(build-lisp-image "clfswm")
+

diff --git a/src/clfswm-internal.lisp b/src/clfswm-internal.lisp
index 81c5e7e..7e404ab 100644 (file)
--- a/src/clfswm-internal.lisp
+++ b/src/clfswm-internal.lisp
@@ -879,6 +879,13 @@ XINERAMA version 1.1 opcode: 150
       (push window acc))
     acc))
 
+(defun get-all-frame-windows (&optional (root *root-frame*))
+  "Return all frame windows in root and in its children"
+  (let ((acc nil))
+    (with-all-frames (root frame)
+      (push (frame-window frame) acc))
+    acc))
+
 
 (defun get-hidden-windows ()
   "Return all hiddens windows"
@@ -1568,9 +1575,11 @@ managed."
   "Windows present when clfswm starts up must be absorbed by clfswm."
   (setf *in-process-existing-windows* t)
   (let ((id-list nil)
-       (all-windows (get-all-windows)))
+       (all-windows (get-all-windows))
+        (all-frame-windows (get-all-frame-windows)))
     (dolist (win (xlib:query-tree (xlib:screen-root screen)))
-      (unless (child-member win all-windows)
+      (unless (or (child-member win all-windows)
+                  (child-member win all-frame-windows))
        (let ((map-state (xlib:window-map-state win))
              (wm-state (window-state win)))
          (unless (or (eql (xlib:window-override-redirect win) :on)

diff --git a/src/clfswm-util.lisp b/src/clfswm-util.lisp
index 841cbed..9e0b396 100644 (file)
--- a/src/clfswm-util.lisp
+++ b/src/clfswm-util.lisp
@@ -64,6 +64,15 @@
 
 
 
+;;;----------------------------
+;;; Lisp image part
+;;;----------------------------
+(defun build-lisp-image (dump-name)
+  #+CLISP (ext:saveinitmem dump-name :init-function (lambda () (clfswm:main) (ext:quit)) :executable t :norc t)
+  #+SBCL (sb-ext:save-lisp-and-die dump-name :toplevel 'clfswm:main :executable t))
+
+
+
 (defun query-yes-or-no (formatter &rest args)
   (let ((rep (query-string (apply #'format nil formatter args) "" '("Yes" "No"))))
     (or (string= rep "")
@@ -941,9 +950,9 @@ For window: set current child to window or its parent according to window-parent
     (dotimes (i 10)
       (setf (aref key-slots i) nil)))
 
-  (defun bind-on-slot (&optional (slot current-slot))
+  (defun bind-on-slot (&optional (slot current-slot) child)
     "Bind current child to slot"
-    (setf (aref key-slots slot) (current-child)))
+    (setf (aref key-slots slot) (if child child (current-child))))
 
   (defun remove-binding-on-slot ()
     "Remove binding on slot"

diff --git a/src/tools.lisp b/src/tools.lisp
index d930362..04b0dc7 100644 (file)
--- a/src/tools.lisp
+++ b/src/tools.lisp
@@ -403,7 +403,6 @@ Return the result of the last hook"
   (force-output))
 
 
-
 (defun in-rectangle (x y rectangle)
   (and rectangle
        (<= (rectangle-x rectangle) x (+ (rectangle-x rectangle) (rectangle-width rectangle)))