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

Diff of /mcclim/frames.lisp

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

revision 1.6 by cvs, Wed Nov 29 19:44:35 2000 UTC revision 1.7 by cvs, Mon Dec 4 14:54:30 2000 UTC
# Line 377  Line 377 
377      (adopt-frame frame-manager frame)      (adopt-frame frame-manager frame)
378      frame))      frame))
379    
380    ;;; Menu frame class
381    
382    (defclass menu-frame ()
383      ((left :initform 0 :initarg :left)
384       (top :initform 0 :initarg :top)
385       (top-level-sheet :initform nil :reader frame-top-level-sheet)
386       (pane :reader frame-pane :initarg :pane)
387       (graft :initform nil :accessor graft)
388       (manager :initform nil :accessor frame-manager)))
389    
390    (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
391      (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
392      (setf (slot-value frame 'manager) fm)
393      (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
394                                 :name 'top-level-sheet)))
395        (setf (slot-value frame 'top-level-sheet) t-l-s)
396        (sheet-adopt-child t-l-s (frame-pane frame))
397        (let ((graft (find-graft :port (frame-manager-port fm))))
398          (sheet-adopt-child graft t-l-s)
399          (setf (graft frame) graft))
400        (let ((space (compose-space t-l-s)))
401          (allocate-space (frame-pane frame)
402                          (space-requirement-width space)
403                          (space-requirement-height space))
404          (setf (sheet-region t-l-s)
405                (make-bounding-rectangle 0 0
406                                         (space-requirement-width space)
407                                         (space-requirement-height space))))
408        (setf (sheet-transformation t-l-s)
409              (make-translation-transformation (slot-value frame 'left)
410                                               (slot-value frame 'top)))))
411    
412    (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
413      (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
414      (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
415      (setf (frame-manager frame) nil))
416    
417    (defun make-menu-frame (pane &key (left 0) (top 0))
418      (make-instance 'menu-frame :pane pane :left left :top top))
419    

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

  ViewVC Help
Powered by ViewVC 1.1.5