home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d3xx / d386 / xlispstat.lha / XLispStat / src1.lzh / IView / menus.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-10-04  |  17.0 KB  |  564 lines
  1. /* menus - Hardware Independent Menu Objects                           */
  2. /* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney                  */
  3. /* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz    */
  4. /* You may give out copies of this software; for conditions see the    */
  5. /* file COPYING included with this distribution.                       */
  6.  
  7. /***********************************************************************/
  8. /**                                                                   **/
  9. /**                    General Includes and Definitions               **/
  10. /**                                                                   **/
  11. /***********************************************************************/
  12.  
  13. #include <string.h>
  14. #include "xlisp.h"
  15. #include "osdef.h"
  16. #ifdef ANSI
  17. #include "xlproto.h"
  18. #include "xlsproto.h"
  19. #include "iviewproto.h"
  20. #include "Stproto.h"
  21. #else
  22. #include "xlfun.h"
  23. #include "xlsfun.h"
  24. #include "iviewfun.h"
  25. #include "Stfun.h"
  26. #endif ANSI
  27. #include "xlvar.h"
  28. #include "xlsvar.h"
  29.  
  30. /* forward declarations */
  31. #ifdef ANSI
  32. LVAL rplac_end(LVAL,LVAL),remove_from_list(LVAL,LVAL),GetMenuList(void),
  33.      simple_menu_message(int),menu_selector_message(int),
  34.      check_item_ivar(int,LVAL),set_item_ivar(int,LVAL,LVAL),
  35.      get_item_ivar(int,LVAL),item_ivar(int);
  36. void SetMenuList(LVAL),append_items(LVAL,LVAL),delete_menu_item(LVAL,LVAL),
  37.      update_menu(LVAL);
  38. #else
  39. LVAL rplac_end(),remove_from_list(),GetMenuList(),
  40.      simple_menu_message(),menu_selector_message(),
  41.      check_item_ivar(),set_item_ivar(),
  42.      get_item_ivar(),item_ivar();
  43.      void SetMenuList(),append_items(),delete_menu_item(),
  44.      update_menu();
  45. #endif
  46.  
  47. /***********************************************************************/
  48. /**                                                                   **/
  49. /**                        MENU-PROTO Definitions                     **/
  50. /**                                                                   **/
  51. /***********************************************************************/
  52.  
  53. # define menu_enabled_p(m) (slot_value(m, s_enabled) != NIL)
  54.  
  55. /***********************************************************************/
  56. /**                                                                   **/
  57. /**                     MENU-ITEM-PROTO Definitions                   **/
  58. /**                                                                   **/
  59. /***********************************************************************/
  60.  
  61. # define item_installed_p(i) (slot_value(i, s_menu) != NIL)
  62.  
  63. /***********************************************************************/
  64. /**                                                                   **/
  65. /**                          Utility Functions                        **/
  66. /**                                                                   **/
  67. /***********************************************************************/
  68.  
  69. /* append item to the end of list and return result. Cons item to NIL */
  70. /* if list is NIL.                                                    */
  71. LOCAL LVAL rplac_end(list, item)
  72.     LVAL list, item; 
  73. {
  74.   LVAL next; 
  75.   if (list == NIL) return(consa(item));
  76.   else if (listp(list)) {
  77.     for (next = list; consp(cdr(next)); next = cdr(next))
  78.       ;
  79.     rplacd(next, consa(item));
  80.     return(list);
  81.   }
  82.   else xlerror("not a list", list);
  83. }
  84.  
  85. LOCAL LVAL remove_from_list(item, list)
  86.     LVAL item, list;
  87. {
  88.   return(xscallsubr2(xremove, item, list));
  89. }
  90.  
  91. /***********************************************************************/
  92. /**                                                                   **/
  93. /**                         Menu List Functions                       **/
  94. /**                                                                   **/
  95. /***********************************************************************/
  96.  
  97. LOCAL LVAL GetMenuList()
  98. {
  99.   return(slot_value(getvalue(s_menu_proto), s_menu_list));
  100. }
  101.  
  102. LOCAL void SetMenuList(list)
  103.     LVAL list;
  104. {
  105.   set_slot_value(getvalue(s_menu_proto), s_menu_list, list);
  106. }
  107.  
  108. /***********************************************************************/
  109. /***********************************************************************/
  110. /**                                                                   **/
  111. /**                          MENU-PROTO Methods                       **/
  112. /**                                                                   **/
  113. /***********************************************************************/
  114. /***********************************************************************/
  115.  
  116. /***********************************************************************/
  117. /**                                                                   **/
  118. /**                      Hardware Address Functions                   **/
  119. /**                                                                   **/
  120. /***********************************************************************/
  121.  
  122. /* check if menu is currently allocated. */
  123. int StMObAllocated(menu)
  124.     LVAL menu;
  125. {
  126.   return(valid_menu_address(slot_value(menu, s_hardware_address)));
  127. }  
  128.  
  129. /***********************************************************************/
  130. /**                                                                   **/
  131. /**               Predicate and Argument Access Function              **/
  132. /**                                                                   **/
  133. /***********************************************************************/
  134.  
  135. /* Is this a menu? */
  136. int menu_p(x)
  137.     LVAL x;
  138. {
  139.   return (kind_of_p(x, getvalue(s_menu_proto)));
  140. }
  141.  
  142. /* get and check a menu from the argument list */
  143. LVAL xsgetmenu()
  144. {
  145.   LVAL menu;
  146.   menu = xlgaobject();
  147.   if (! menu_p(menu)) xlerror("not a menu", menu);
  148.   return(menu);
  149. }
  150.  
  151. /***********************************************************************/
  152. /**                                                                   **/
  153. /**                         Support Functions                         **/
  154. /**                                                                   **/
  155. /***********************************************************************/
  156.  
  157. /* append list of items to the menu */
  158. static void append_items(menu, new_items)
  159.     LVAL menu, new_items;
  160. {
  161.   LVAL next, item, item_list;
  162.   
  163.   /* Check all items are menu items and not installed */
  164.   for (next = new_items; consp(next); next = cdr(next)) {
  165.     item = car(next);
  166.     if (! menu_item_p(item)) xlerror("not a menu item", item);
  167.     if (item_installed_p(item)) xlerror("item already installed", item);
  168.   }
  169.   
  170.   /* add items to the item list and set items menus to menu */
  171.   for (next = new_items; consp(next); next = cdr(next)) {
  172.     item = car(next);
  173.     item_list = rplac_end(slot_value(menu, s_items), item);
  174.     set_slot_value(menu, s_items,item_list);
  175.     set_slot_value(item, s_menu, menu);
  176.   }
  177.             
  178.   if (StMObAllocated(menu)) StMObAppendItems(menu, new_items);
  179. }
  180.  
  181. /* delete item from the list */
  182. static void delete_menu_item(menu, item)
  183.     LVAL menu, item;
  184. {
  185.   LVAL item_list;
  186.    
  187.   StMObDeleteItem(menu, item);
  188.   
  189.   item_list = slot_value(menu, s_items);
  190.   item_list = remove_from_list(item, item_list);
  191.   set_slot_value(menu, s_items,item_list);
  192.   set_slot_value(item, s_menu, NIL);
  193. }
  194.    
  195. /* allocate a menu and enter it into the list of allocated menus */
  196. void StMObAllocate(menu)
  197.     LVAL menu;
  198. {
  199.   LVAL menu_list;
  200.   
  201.   StMObDispose(menu);
  202.  
  203.   StMObAllocateMach(menu);
  204.   
  205.   StMObEnable(menu, menu_enabled_p(menu));
  206.   StMObAppendItems(menu, slot_value(menu, s_items));
  207.     
  208.   menu_list = GetMenuList();
  209.   menu_list = xscallsubr2(xsadjoin, menu, menu_list);
  210.   SetMenuList(menu_list);
  211. }
  212.  
  213. /* send :UPDATE message to menu items */
  214. static void update_menu(menu)
  215.     LVAL menu;
  216. {
  217.   LVAL list;
  218.   
  219.   for (list = slot_value(menu, s_items); consp(list); list = cdr(list))
  220.     send_message(car(list), sk_update);
  221. }
  222.  
  223. /* dispose of a menu */
  224. void StMObDispose(menu)
  225.     LVAL menu;
  226. {
  227.   LVAL menu_list;
  228.   
  229.   if (StMObAllocated(menu)) StMObDisposeMach(menu);
  230.   standard_hardware_clobber(menu);
  231.  
  232.   menu_list = GetMenuList();
  233.   menu_list = remove_from_list(menu, menu_list);
  234.   SetMenuList(menu_list);
  235. }
  236.  
  237. /* handle simple imperative messages with no arguments */
  238. static LVAL simple_menu_message(which)
  239.     int which;
  240. {
  241.   LVAL menu;
  242.   LVAL arg;
  243.   int set = FALSE;
  244.     
  245.   menu = xlgaobject();
  246.   if (which == 'E') {
  247.     if (moreargs()) {
  248.       set = TRUE;
  249.       arg = (xlgetarg() != NIL) ? s_true : NIL;
  250.     }
  251.   }
  252.   xllastarg();
  253.   
  254.   switch (which) {
  255.   case 'A': StMObAllocate(menu); break;
  256.   case 'D': StMObDispose(menu); break;
  257.   case 'E': if (set) {
  258.               set_slot_value(menu, s_enabled, arg);
  259.               StMObEnable(menu, (arg != NIL));
  260.             }
  261.             return(slot_value(menu, s_enabled));
  262.   case 'I': StMObInstall(menu); break;
  263.   case 'R': StMObRemove(menu); break;
  264.   case 'U': update_menu(menu); break;
  265.   default:  xlfail("unknown message");
  266.   }
  267.   
  268.   return(NIL);
  269. }
  270.  
  271. /* handle instance variable selectors/status inquiries */
  272. static LVAL menu_selector_message(which)
  273.     int which;
  274. {
  275.   LVAL menu, result;
  276.   
  277.   menu = xlgaobject();
  278.   xllastarg();
  279.  
  280.   switch (which) {
  281.   case 'A': result = (StMObAllocated(menu)) ? s_true : NIL; break;
  282.   case 'I': result = slot_value(menu, s_items); break;
  283.   case 'i': result = (StMObInstalled(menu)) ? s_true : NIL; break;
  284.   default:  xlfail("unknown message");
  285.   }
  286.   return(result);
  287. }
  288.  
  289. /***********************************************************************/
  290. /**                                                                   **/
  291. /**                              Methods                              **/
  292. /**                                                                   **/
  293. /***********************************************************************/
  294.  
  295. /* :ISNEW Method */
  296. LVAL xsmenu_isnew()
  297. {
  298.   LVAL menu, title;
  299.     
  300.   menu = xlgaobject();
  301.   title = xlgastring();
  302.   xllastarg();
  303.  
  304.   if (strlen(getstring(title)) <= 0) xlerror("title is too short", title);
  305.   
  306.   object_isnew(menu);
  307.   set_slot_value(menu, s_title, title);
  308.   set_slot_value(menu, s_enabled, s_true);
  309.  
  310.   return(menu);
  311. }
  312.  
  313. LVAL xsallocate_menu() { return(simple_menu_message('A')); }
  314. LVAL xsdispose_menu()  { return(simple_menu_message('D')); }
  315. LVAL xsupdate_menu()   { return(simple_menu_message('U')); }
  316. LVAL xsallocated_p()  { return(menu_selector_message('A')); }
  317. LVAL xsmenu_items()   { return(menu_selector_message('I')); }
  318.  
  319. LVAL xsinstall_menu()  { return(simple_menu_message('I')); }
  320. LVAL xsremove_menu()   { return(simple_menu_message('R')); }
  321. LVAL xsinstalled_p()  { return(menu_selector_message('i')); }
  322.  
  323. LVAL xsmenu_enabled()   { return(simple_menu_message('E')); }
  324.  
  325. /* :APPEND-ITEMS Method */
  326. LVAL xsappend_items()
  327. {
  328.   LVAL menu, new_items;
  329.     
  330.   xlsave1(new_items);
  331.   menu = xlgaobject();
  332.   new_items = makearglist(xlargc, xlargv);
  333.   append_items(menu, new_items);
  334.   xlpop();
  335.   return(NIL);
  336. }
  337.  
  338. /* :DELETE-ITEMS Method */
  339. LVAL xsdelete_items()
  340. {
  341.   LVAL menu;
  342.     
  343.   menu = xlgaobject();
  344.   while (moreargs())
  345.     delete_menu_item(menu, xlgaobject());
  346.   return(NIL);
  347. }
  348.  
  349. /* :SELECT Method */
  350. LVAL xsmenu_select()
  351. {
  352.   LVAL menu, item, next;
  353.   int i;
  354.  
  355.   menu = xsgetmenu();
  356.   i = getfixnum(xlgafixnum());
  357.   xllastarg();
  358.  
  359.   for (next = slot_value(menu, s_items);
  360.        i > 1 && consp(next); i--, next = cdr(next))
  361.     ;
  362.   if (! consp(next)) xlfail("no item with this index in the menu");
  363.   else item = car(next);
  364.   
  365.   send_message(item, sk_do_action);
  366.   
  367.   return(NIL);
  368. }
  369.  
  370. LVAL xsmenu_title()
  371. {
  372.   LVAL menu, title;
  373.  
  374.   menu = xlgaobject();
  375.   if (moreargs()) {
  376.     title = xlgastring();
  377.     if (strlen(getstring(title)) <= 0)
  378.       xlerror("title is too short", title);
  379.     if (StMObAllocated(menu))
  380.       xlfail("can't change title of an allocated menu");
  381.     set_slot_value(menu, s_title, title);
  382.   }
  383.   return(slot_value(menu, s_title));
  384. }
  385.  
  386. LVAL xsmenu_popup()
  387. {
  388.   LVAL menu, window;
  389.   int left, top, item;
  390.   
  391.   menu = xsgetmenu();
  392.   left = getfixnum(xlgafixnum());
  393.   top = getfixnum(xlgafixnum());
  394.   window = (moreargs()) ? xlgaobject() : NIL;
  395.   xllastarg();
  396.   
  397.   send_message(menu, sk_update);
  398.   item = StMObPopup(menu, left, top, window);
  399.   if (item > 0) send_message1(menu, sk_select, item);
  400.   return(cvfixnum((FIXTYPE) item));
  401. }
  402.     
  403.  
  404. /***********************************************************************/
  405. /***********************************************************************/
  406. /**                                                                   **/
  407. /**                     MENU-ITEM-PROTO Methods                       **/
  408. /**                                                                   **/
  409. /***********************************************************************/
  410. /***********************************************************************/
  411.  
  412. /***********************************************************************/
  413. /**                                                                   **/
  414. /**              Predicate and Argument Access Function               **/
  415. /**                                                                   **/
  416. /***********************************************************************/
  417.  
  418. /* is this a menu item ? */
  419. int menu_item_p(x)
  420.     LVAL x;
  421. {
  422.   return(kind_of_p(x, getvalue(s_menu_item_proto)));
  423. }
  424.  
  425. /* get and check a menu item from the argument stack */
  426. LVAL xsgetmenuitem()
  427. {
  428.     LVAL item;
  429.     
  430.     item = xlgaobject();
  431.     if (! menu_item_p(item)) xlerror("not a menu item", item);
  432.     return(item);
  433. }
  434.  
  435. /***********************************************************************/
  436. /**                                                                   **/
  437. /**                        Support Function                           **/
  438. /**                                                                   **/
  439. /***********************************************************************/
  440.  
  441. /* check an item instance variable */
  442. static LVAL check_item_ivar(which, value)
  443.     int which;
  444.     LVAL value;
  445. {
  446.   int good;
  447.   
  448.   switch (which) {
  449.   case 'T': good = (stringp(value) && strlen(getstring(value)) > 0); break;
  450.   case 'K': good = (charp(value) || value == NIL); break;
  451.   case 'M': good = (charp(value) || value == NIL || value == s_true); break;
  452.   case 'S': good = (symbolp(value) || listp(value)); break;
  453.   case 'A': good = (value == NIL || symbolp(value) || closurep(value) || subrp(value)); break;
  454.   case 'E': good = TRUE; value = (value != NIL) ? s_true : NIL; break;
  455.   default:  xlfail("unknown item instance variable");
  456.   }
  457.   if (! good) xlerror("bad instance variable value", value);
  458.   return(value);
  459. }
  460.  
  461. /* set an item instance variable; item and value supplied or on the stack */
  462. static LVAL set_item_ivar(which, item, value)
  463.     int which;
  464.     LVAL item, value;
  465. {
  466.   value = check_item_ivar(which, value);
  467.   
  468.   switch (which) {
  469.   case 'T': set_slot_value(item, s_title, value); break;
  470.   case 'K': set_slot_value(item, s_key, value); break;
  471.   case 'M': set_slot_value(item, s_mark, value); break;
  472.   case 'S': set_slot_value(item, s_style, value); break;
  473.   case 'A': set_slot_value(item, s_action, value); break;
  474.   case 'E': set_slot_value(item, s_enabled, value); break;
  475.   default:  xlfail("unknown item instance variable");
  476.   }
  477.   
  478.   StMObSetItemProp(item, which);
  479.   return(value);
  480. }
  481.  
  482. /* get an item instance variable; item and value supplied or on the stack */
  483. static LVAL get_item_ivar(which, item)
  484.     int which;
  485.     LVAL item;
  486. {
  487.   LVAL value;
  488.     
  489.   switch (which) {
  490.   case 'T': value = slot_value(item, s_title); break;
  491.   case 'K': value = slot_value(item, s_key); break;
  492.   case 'M': value = slot_value(item, s_mark); break;
  493.   case 'S': value = slot_value(item, s_style); break;
  494.   case 'A': value = slot_value(item, s_action); break;
  495.   case 'E': value = slot_value(item, s_enabled); break;
  496.   default:  xlfail("unknown item instance variable");
  497.   }
  498.   return(check_item_ivar(which, value));
  499. }
  500.  
  501. static LVAL item_ivar(which)
  502.     int which;
  503. {
  504.   LVAL item;
  505.   
  506.   item = xlgaobject();
  507.   if (moreargs()) set_item_ivar(which, item, xlgetarg());
  508.   return(get_item_ivar(which, item));
  509. }
  510.  
  511. /***********************************************************************/
  512. /**                                                                   **/
  513. /**                            Methods                                **/
  514. /**                                                                   **/
  515. /***********************************************************************/
  516.  
  517. /* :ISNEW Method */
  518. LVAL xsitem_isnew()
  519. { 
  520.   LVAL item, title, value;
  521.   
  522.   item = xlgaobject();
  523.   title = xlgastring();
  524.   
  525.   set_item_ivar('T', item, title);
  526.   object_isnew(item);
  527.   
  528.   if (xlgetkeyarg(sk_enabled, &value)) set_item_ivar('E', item, value);
  529.   else set_item_ivar('E', item, s_true);
  530.   return(NIL);  /* to keep compilers happy - L. Tierney */
  531. }
  532.  
  533. LVAL xsitem_title()       { return(item_ivar('T')); }
  534. LVAL xsitem_key()         { return(item_ivar('K')); }
  535. LVAL xsitem_mark()        { return(item_ivar('M')); }
  536. LVAL xsitem_style()       { return(item_ivar('S')); }
  537. LVAL xsitem_action()      { return(item_ivar('A')); }
  538. LVAL xsitem_enabled()     { return(item_ivar('E')); }
  539.  
  540. /* :INSTALLED-P Method */
  541. LVAL xsitem_installed_p() 
  542. {
  543.   LVAL item;
  544.   item = xsgetmenuitem();
  545.   xllastarg();
  546.   
  547.   return((item_installed_p(item)) ? s_true :  NIL);
  548.   
  549. }
  550.  
  551. LVAL xsitem_update()      { return(NIL); }
  552.  
  553. /* :DO-ACTION Method */
  554. LVAL xsitem_do_action()
  555. { 
  556.   LVAL item, action, result;
  557.   item = xsgetmenuitem();
  558.   xllastarg();
  559.   
  560.   action = slot_value(item, s_action);
  561.   result = (action != NIL) ? xlapply(pushargs(action, NIL)) : NIL;
  562.   return(result);
  563. }
  564.