/[mcclim]/mcclim/frames.lisp
ViewVC logotype

Diff of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.51 by moore, Sun Aug 18 06:27:04 2002 UTC revision 1.52 by moore, Tue Sep 24 01:56:29 2002 UTC
# Line 90  Line 90 
90     (calling-frame :initarg :calling-frame     (calling-frame :initarg :calling-frame
91                    :initform nil)                    :initform nil)
92     (state :initarg :state     (state :initarg :state
93            :initform nil            :initform :disowned
94            :accessor frame-state)            :reader frame-state)
95     (manager :initform nil     (manager :initform nil
96              :reader frame-manager              :reader frame-manager
97              :accessor %frame-manager)              :accessor %frame-manager)
# Line 317  FRAME-EXIT condition.")) Line 317  FRAME-EXIT condition."))
317          (*input-context* nil)          (*input-context* nil)
318          (*input-wait-test* nil)          (*input-wait-test* nil)
319          (*input-wait-handler* nil)          (*input-wait-handler* nil)
320          (*pointer-button-press-handler* nil))          (*pointer-button-press-handler* nil)
321            (original-state (frame-state frame)))
322      (declare (special *input-context* *input-wait-test* *input-wait-handler*      (declare (special *input-context* *input-wait-test* *input-wait-handler*
323                        *pointer-button-press-handler*))                        *pointer-button-press-handler*))
324        (when (eq (frame-state frame) :disowned)
325          (adopt-frame (or (frame-manager frame) (find-frame-manager))
326                       frame))
327        (unless (or (eq (frame-state frame) :enabled)
328                    (eq (frame-state frame) :shrunk))
329          (enable-frame frame))
330      (let ((query-io (frame-query-io frame)))      (let ((query-io (frame-query-io frame)))
331        (if query-io        (unwind-protect
332            (with-input-focus (query-io)             (if query-io
333              (call-next-method))                 (with-input-focus (query-io)
334            (call-next-method)))))                   (call-next-method))
335                   (call-next-method))
336            (case original-state
337              (:disabled
338               (disable-frame frame))
339              (:disowned
340               (disown-frame (frame-manager frame) frame)))))))
341    
342  (defmethod default-frame-top-level  (defmethod default-frame-top-level
343      ((frame application-frame)      ((frame application-frame)
# Line 393  FRAME-EXIT condition.")) Line 406  FRAME-EXIT condition."))
406  (defmethod adopt-frame ((fm frame-manager) (frame application-frame))  (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
407    (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))    (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
408    (setf (frame-manager frame) fm)    (setf (frame-manager frame) fm)
409      (setf (port frame) (frame-manager-port fm))
410      (setf (graft frame) (find-graft :port (port frame)))
411    (let* ((*application-frame* frame)    (let* ((*application-frame* frame)
412           (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane           (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
413                               :name 'top-level-sheet)))                               :name 'top-level-sheet
414                                 ;; enabling should be left to enable-frame
415                                 :enabled-p nil)))
416      (setf (slot-value frame 'top-level-sheet) t-l-s)      (setf (slot-value frame 'top-level-sheet) t-l-s)
417      (generate-panes fm frame)))      (generate-panes fm frame)
418        (setf (slot-value frame 'state)  :disabled)
419        frame))
420    
421  (defmethod disown-frame ((fm frame-manager) (frame application-frame))  (defmethod disown-frame ((fm frame-manager) (frame application-frame))
422    (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))    (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
423    (sheet-disown-child (graft frame) (frame-top-level-sheet frame))    (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
424    (setf (%frame-manager frame) nil))    (setf (%frame-manager frame) nil)
425      (setf (slot-value frame 'state) :disowned)
426      frame)
427    
428    (defgeneric enable-frame (frame))
429    (defgeneric disable-frame (frame))
430    
431    (defgeneric note-frame-enabled (frame-manager frame))
432    (defgeneric note-frame-disbled (frame-manager frame))
433    
434    (defmethod enable-frame ((frame application-frame))
435      (setf (sheet-enabled-p (frame-top-level-sheet frame)) t)
436      (setf (slot-value frame 'state) :enabled)
437      (note-frame-enabled (frame-manager frame) frame))
438    
439    (defmethod disable-frame ((frame application-frame))
440      (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil)
441      (setf (slot-value frame 'state) :disabled)
442      (note-frame-disabled (frame-manager frame) frame))
443    
444    (defmethod note-frame-enabled ((fm frame-manager) frame)
445      (declare (ignore frame))
446      t)
447    
448    (defmethod note-frame-disabled ((fm frame-manager) frame)
449      t)
450    
451  (defvar *pane-realizer* nil)  (defvar *pane-realizer* nil)
452    
# Line 573  FRAME-EXIT condition.")) Line 617  FRAME-EXIT condition."))
617    
618  (defun make-application-frame (frame-name  (defun make-application-frame (frame-name
619                                 &rest options                                 &rest options
620                                 &key pretty-name frame-manager enable state                                 &key (pretty-name
621                                      left top right bottom width height save-under                                       (string-capitalize frame-name))
622                                      frame-class                                      (frame-manager nil frame-manager-p)
623                                        enable
624                                        (state nil state-supplied-p)
625                                        left top right bottom width height
626                                        save-under (frame-class frame-name)
627                                 &allow-other-keys)                                 &allow-other-keys)
628    (declare (ignore enable state left top right bottom width height save-under))    (declare (ignore left top right bottom width height save-under))
629    (setq options (loop for (key value) on options by #'cddr    (with-keywords-removed (options (:pretty-name :frame-manager :enable :state
630                      if (not (member key '(:pretty-name :frame-manager :enable :state                                     :left :top :right :bottom :width :height
631                                            :left :top :right :bottom :width :height :save-under                                     :save-under:frame-class))
632                                            :frame-class)      (let ((frame (apply #'make-instance frame-class
633                                      :test #'eq))                          :name frame-name :pretty-name pretty-name options)))
634                         nconc (list key value)))        (when frame-manager-p
635    (if (null frame-class)          (adopt-frame frame-manager frame))
636        (setq frame-class frame-name))        (cond ((or enable (eq state :enabled))
637    (if (null pretty-name)               (enable-frame frame))
638        (setq pretty-name (string-capitalize frame-name)))              ((and (eq state :disowned)
639    (if (null frame-manager)                    (not (eq (frame-state frame) :disowned)))
640        (setq frame-manager (find-frame-manager)))               (disown-frame (frame-manager frame) frame))
641    (let ((frame (apply #'make-instance frame-class              (state-supplied-p
642                        :port (frame-manager-port frame-manager)               (warn ":state ~S not supported yet." state)))
643                        :graft (find-graft :port (frame-manager-port frame-manager))        frame)))
                       :name frame-name :pretty-name pretty-name options)))  
     (adopt-frame frame-manager frame)  
     frame))  
644    
645  ;;; Menu frame class  ;;; Menu frame class
646    

Legend:
Removed from v.1.51  
changed lines
  Added in v.1.52

  ViewVC Help
Powered by ViewVC 1.1.5