Fix for subsurfaces (cheese wasn't showing video) and weston-presenta…

…tion-shm was causing a crash because wl-shell-surface needs to be ianimatable.

desktop-mode.lisp

@@ -238,7 +238,7 @@
 			   :surface-translate (m4:translation (cepl:v! (x surface) (y surface) 0.0))
 			   :texture texture
 			   :alpha (opacity surface))))
-    (loop :for subsurface :in (subsurfaces surface)
+    (loop :for subsurface :in (subsurfaces (wl-surface surface))
        :do (render subsurface view-fbo))))
 
 (defmethod render ((surface wl-subsurface) &optional view-fbo)
@@ -247,21 +247,21 @@
       (let ((texture (texture-of surface)))
 	(gl:viewport 0 0 (screen-width *compositor*) (screen-height *compositor*))
 	(map-g-default/fbo view-fbo #'mapping-pipeline vertex-stream
-			   :origin (m4:translation (cepl:v! (+ (x surface) (- (origin-x (parent surface))))
-							    (+ (y surface) (- (origin-y (parent surface))))
+			   :origin (m4:translation (cepl:v! (+ (x surface) (- (origin-x (role (parent surface)))))
+							    (+ (y surface) (- (origin-y (role (parent surface)))))
 							    0))
-			   :origin-inverse (m4:translation (cepl:v! (+ (- (x surface)) (origin-x (parent surface)))
-								    (+ (- (y surface)) (origin-y (parent surface)))
+			   :origin-inverse (m4:translation (cepl:v! (+ (- (x surface)) (origin-x (role (parent surface))))
+								    (+ (- (y surface)) (origin-y (role (parent surface))))
 								    0))
-			   :surface-scale (m4:scale (cepl:v! (scale-x (parent surface))
-							     (scale-y (parent surface))
+			   :surface-scale (m4:scale (cepl:v! (scale-x (role (parent surface)))
+							     (scale-y (role (parent surface)))
 							     1.0))
-			   :surface-translate (m4:translation (cepl:v! (+ (x (parent surface)) (x surface))
-								       (+ (y (parent surface)) (y surface))
+			   :surface-translate (m4:translation (cepl:v! (+ (x (role (parent surface))) (x surface))
+								       (+ (y (role (parent surface))) (y surface))
 								       0.0))
 			   :texture texture
 			   :alpha (opacity surface))))
-    (loop :for subsurface :in (subsurfaces surface)
+    (loop :for subsurface :in (subsurfaces (wl-surface surface))
        :do (render subsurface view-fbo))))
 
 (defmethod render ((mode desktop-mode) &optional view-fbo)

wl-shell-surface-impl.lisp

@@ -1,6 +1,6 @@
 
 (in-package :ulubis)
 
-(defimplementation wl-shell-surface (isurface)
+(defimplementation wl-shell-surface (isurface ianimatable)
   ()
   ())

wl-subcompositor-impl.lisp

@@ -5,10 +5,10 @@
   (let* ((subsurface (make-wl-subsurface client (get-version subcompositor) id))
 	 (surface (find-resource client surface-ptr))
 	 (parent (find-resource client parent-ptr)))
-    (setf (parent subsurface) (role parent))
+    (setf (parent subsurface) parent)
     (setf (wl-surface subsurface) surface)
     (setf (role surface) subsurface)
-    (push subsurface (subsurfaces (role parent)))))
+    (push subsurface (subsurfaces parent))))
 
 (defimplementation wl-subcompositor ()
   ((:get-subsurface get-subsurface))

wl-subsurface-impl.lisp

@@ -6,6 +6,11 @@
     (setf (x subsurface) x)
     (setf (y subsurface) y)))
 
+(def-wl-callback subsurface-destroy (client subsurface)
+  (with-slots (parent) subsurface
+    (setf (subsurfaces parent) (remove subsurface (subsurfaces parent)))))
+
 (defimplementation wl-subsurface (isurface ianimatable)
-  ((:set-position set-position))
+  ((:set-position set-position)
+   (:destroy subsurface-destroy))
   ((parent :accessor parent :initarg :parent :initform nil)))

wl-surface-impl.lisp

@@ -47,3 +47,8 @@
    (role :accessor role :initarg :role :initform nil)
    (buffer :accessor buffer :initarg :buffer :initform nil)
    (first-commit? :accessor first-commit? :initarg :first-commit? :initform t)))
+
+;; Override print object
+(defmethod print-object ((obj wl-surface) out)
+  (print-unreadable-object (obj out :type t)
+    (format out "~s@~X [~Ax~A]" (id obj) (cffi:pointer-address (->resource obj)) (width obj) (height obj))))