home *** CD-ROM | disk | FTP | other *** search
/ ftp.freefriends.org / ftp.freefriends.org.tar / ftp.freefriends.org / arnold / Source / gwm-dist.tar.gz / gwm-dist.tar / home-gwm / pop-menu.gwm < prev    next >
Lisp/Scheme  |  1993-07-07  |  3KB  |  87 lines
  1. ; My version of pop-menu.  Uses a property to remember what the last
  2. ; selection was, and pops the menu at that position.
  3. ;
  4. ; NOTE WELL -- must be loaded AFTER `std-popups.gwm' since it supersedes
  5. ; the definition of `item-make' in that file, but BEFORE `item-make' is
  6. ; actually used (currently, only in `def-menus.gwm').  This means it
  7. ; goes fine in `.profile.gwm'.
  8.  
  9. (if (not (boundp 'primitive-pop-menu))
  10.     (: primitive-pop-menu pop-menu))
  11.  
  12. (de pop-err (s)
  13.     (? "ERROR: " s "\n" (+ '(pop-menu) arglist) "\n")
  14.     (exit my-pop-menu-tag nil))
  15.  
  16. (df pop-menu arglist
  17.     (with (m wob-menu pos nil)
  18.     (tag my-pop-menu-tag
  19.         (if arglist
  20.         (if (> (length arglist) 2)
  21.             (pop-err "pop-menu takes 0 to 2 arguments:")
  22.             (if (error-occurred (: m (eval (# 0 arglist))))
  23.             (pop-err "error in evaluation of first argument:")
  24.             (not (eq (type m) 'menu))
  25.             (pop-err "first argument isn't a menu:")
  26.             (= (length arglist) 2)
  27.             (if (error-occurred (: pos (eval (# 1 arglist))))
  28.                 (pop-err "error in evaluation of second argument:")
  29.                 (not (eq (type pos) 'number))
  30.                 (pop-err "second argument isn't a number:")))))
  31.         (if (null pos)
  32.         (: pos (with (wob (menu-wob m)) (# 'last-menu-position wob-property))))
  33.         (if (null pos)
  34.         (: pos 0))
  35.         (primitive-pop-menu m pos))))
  36.  
  37. (if (not (boundp 'primitive-menu-make))
  38.     (: primitive-menu-make menu-make))
  39.  
  40. (df menu-make items
  41.     (with (menu-make-item-position 0)
  42.     (eval (+ '(primitive-menu-make) items))))
  43.  
  44. (setq std-popups.fsm  (fsm-make 
  45.               (: closed 
  46.                  (state-make 
  47.                  (on enter-window (std-popups.enter) opened)))
  48.               (: opened
  49.                  (state-make
  50.                  (on (buttonrelease any any)
  51.                      (progn
  52.                        (setq std-popups.action
  53.                          (# 'action wob-property))
  54.                        (wob wob-parent)
  55.                        (unpop-menu wob)
  56.                        (wob wob-parent)
  57.                        (eval std-popups.action)
  58.                      )
  59.                      closed)
  60.                  (on enter-window (std-popups.enter))
  61.                  (on leave-window (wob-invert))))))
  62.  
  63. (de std-popups.enter nil
  64.     (wob-invert)
  65.     (with (pos (# 'position wob-property))
  66.     (with (wob wob-parent)
  67.         (wob-property (# 'last-menu-position wob-property pos)))))
  68.  
  69. (df item-make (label action)
  70.     (with (borderwidth 0 ; was 1
  71.        inner-borderwidth 0
  72.        borderpixel white
  73.        fsm std-popups.fsm
  74.        label-vertical-margin 0
  75.        property
  76.         (+ (list
  77.             'action action
  78.             'position menu-make-item-position)
  79.             property))
  80.     (: menu-make-item-position (+ 1 menu-make-item-position))
  81.     (bar-make
  82.         nil
  83.         (with (borderwidth 0 fsm nil font pop-item-font
  84.             bar-min-width pop-item-height)
  85.         (plug-make (label-make label)))
  86.         nil)))
  87.