[mcclim-cvs] CVS mcclim

[ahefner]

Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv5175

Modified Files:
	frames.lisp 
Log Message:

Make :default-initargs work as a parameter to define-application-frame.



--- /project/mcclim/cvsroot/mcclim/frames.lisp	2007/01/04 09:13:25	1.123
+++ /project/mcclim/cvsroot/mcclim/frames.lisp	2007/02/05 02:55:29	1.124
@@ -238,8 +238,9 @@
 
 (defmethod layout-frame ((frame application-frame) &optional width height)
   (let ((pane (frame-panes frame)))
-    (if (and  width (not height))
-	(error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
+    (when (and (or width height)
+               (not (and width height)))
+      (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
     (if (and (null width) (null height))
 	(let ((space (compose-space pane))) ;I guess, this might be wrong. --GB 2004-06-01
 	  (setq width (space-requirement-width space))
@@ -600,7 +601,7 @@
          #+clim-mp (event-queue (sheet-event-queue t-l-s)))
     (setf (slot-value frame 'top-level-sheet) t-l-s)
     (generate-panes fm frame)
-    (setf (slot-value frame 'state)  :disabled)
+    (setf (slot-value frame 'state) :disabled)
     #+clim-mp
     (when (typep event-queue 'port-event-queue)
       (setf (event-queue-port event-queue)
@@ -795,6 +796,7 @@
 	(others nil)	
 	(pointer-documentation nil)
 	(geometry nil)
+	(user-default-initargs nil)
 	(frame-arg (gensym "FRAME-ARG")))
     (loop for (prop . values) in options
 	do (case prop
@@ -810,6 +812,7 @@
 	     (:top-level (setq top-level (first values)))
 	     (:pointer-documentation (setq pointer-documentation (car values)))
 	     (:geometry (setq geometry values))
+	     (:default-initargs (setq user-default-initargs values))
 	     (t (push (cons prop values) others))))
     (when (eq command-definer t)
       (setf command-definer
@@ -838,7 +841,8 @@
          :top-level (list ',(car top-level) ,@(cdr top-level))
          :top-level-lambda (lambda (,frame-arg)
                              (,(car top-level) ,frame-arg
-                               ,@(cdr top-level))))
+                               ,@(cdr top-level)))
+	 , at user-default-initargs)
         , at others)
       ;; We alway set the frame class default geometry, so that the
       ;; user can undo the effect of a specified :geometry option.
@@ -943,11 +947,14 @@
    (graft :initform nil :accessor graft)
    (manager :initform nil :accessor frame-manager)))
 
+(defclass menu-unmanaged-top-level-sheet-pane (unmanaged-top-level-sheet-pane)
+  ())
+
 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
   (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
   (setf (frame-manager frame) fm)
   (let* ((t-l-s (make-pane-1 fm *application-frame*
-                             'unmanaged-top-level-sheet-pane
+                             'menu-unmanaged-top-level-sheet-pane
 			     :name 'top-level-sheet)))
     (setf (slot-value frame 'top-level-sheet) t-l-s)
     (sheet-adopt-child t-l-s (frame-panes frame))