/* menus - Hardware Independent Menu Objects */
/* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney */
/* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz */
/* You may give out copies of this software; for conditions see the */
/* file COPYING included with this distribution. */
/***********************************************************************/
/** **/
/** General Includes and Definitions **/
/** **/
/***********************************************************************/
#include "xlisp.h"
#include "xlstat.h"
/* external variables */
extern LVAL s_true, s_title, s_items, s_enabled, s_id, s_menu_list, s_key,
s_mark, s_style, s_action, s_menu, s_menu_proto, s_apple_menu_proto,
s_menu_item_proto, sk_select, sk_update, sk_do_action, s_bold, s_italic,
s_underline, s_outline, s_shadow, s_condense, s_extend, sk_enabled,
s_hardware_address, sk_allocate, sk_dispose;
/***********************************************************************/
/** **/
/** MENU-PROTO Definitions **/
/** **/
/***********************************************************************/
#define menu_enabled_p(m) (slot_value(m, s_enabled) != NIL)
/***********************************************************************/
/** **/
/** MENU-ITEM-PROTO Definitions **/
/** **/
/***********************************************************************/
#define item_installed_p(i) (slot_value(i, s_menu) != NIL)
/***********************************************************************/
/** **/
/** Utility Functions **/
/** **/
/***********************************************************************/
/* append item to the end of list and return result. Cons item to NIL */
/* if list is NIL. */
LOCAL LVAL rplac_end P2C(LVAL, list, LVAL, item)
{
LVAL next;
if (list == NIL) return(consa(item));
else if (listp(list)) {
for (next = list; consp(cdr(next)); next = cdr(next))
;
rplacd(next, consa(item));
return(list);
}
else xlerror("not a list", list);
return NIL; /* not reached */
}
LOCAL LVAL remove_from_list P2C(LVAL, item, LVAL, list)
{
return(xlcallsubr2(xremove, item, list));
}
/***********************************************************************/
/** **/
/** Menu List Functions **/
/** **/
/***********************************************************************/
LOCAL LVAL GetMenuList(V)
{
return(slot_value(getvalue(s_menu_proto), s_menu_list));
}
LOCAL VOID SetMenuList P1C(LVAL, list)
{
set_slot_value(getvalue(s_menu_proto), s_menu_list, list);
}
/***********************************************************************/
/***********************************************************************/
/** **/
/** MENU-PROTO Methods **/
/** **/
/***********************************************************************/
/***********************************************************************/
/***********************************************************************/
/** **/
/** Hardware Address Functions **/
/** **/
/***********************************************************************/
/* check if menu is currently allocated. */
int StMObAllocated P1C(LVAL, menu)
{
return(valid_menu_address(slot_value(menu, s_hardware_address)));
}
/***********************************************************************/
/** **/
/** Predicate and Argument Access Function **/
/** **/
/***********************************************************************/
/* Is this a menu? */
int menu_p P1C(LVAL, x)
{
return (kind_of_p(x, getvalue(s_menu_proto)));
}
/* get and check a menu from the argument list */
LVAL xsgetmenu(V)
{
LVAL menu;
menu = xlgaobject();
if (! menu_p(menu)) xlerror("not a menu", menu);
return(menu);
}
/***********************************************************************/
/** **/
/** Support Functions **/
/** **/
/***********************************************************************/
/* append list of items to the menu */
static VOID append_items P2C(LVAL, menu, LVAL, new_items)
{
LVAL next, item, item_list;
/* Check all items are menu items and not installed */
for (next = new_items; consp(next); next = cdr(next)) {
item = car(next);
if (! menu_item_p(item)) xlerror("not a menu item", item);
if (item_installed_p(item)) xlerror("item already installed", item);
}
/* add items to the item list and set items menus to menu */
for (next = new_items; consp(next); next = cdr(next)) {
item = car(next);
item_list = rplac_end(slot_value(menu, s_items), item);
set_slot_value(menu, s_items,item_list);
set_slot_value(item, s_menu, menu);
}
if (StMObAllocated(menu)) StMObAppendItems(menu, new_items);
}
/* delete item from the list */
static VOID delete_menu_item P2C(LVAL, menu, LVAL, item)
{
LVAL item_list;
StMObDeleteItem(menu, item);
item_list = slot_value(menu, s_items);
item_list = remove_from_list(item, item_list);
set_slot_value(menu, s_items,item_list);
set_slot_value(item, s_menu, NIL);
}
/* allocate a menu and enter it into the list of allocated menus */
VOID StMObAllocate P1C(LVAL, menu)
{
LVAL menu_list;
StMObDispose(menu);
StMObAllocateMach(menu);
StMObEnable(menu, menu_enabled_p(menu));
StMObAppendItems(menu, slot_value(menu, s_items));
menu_list = GetMenuList();
menu_list = xlcallsubr2(xadjoin, menu, menu_list);
SetMenuList(menu_list);
}
/* send :UPDATE message to menu items */
static VOID update_menu P1C(LVAL, menu)
{
LVAL list;
for (list = slot_value(menu, s_items); consp(list); list = cdr(list))
send_message(car(list), sk_update);
}
/* dispose of a menu */
VOID StMObDispose P1C(LVAL, menu)
{
LVAL menu_list;
if (StMObAllocated(menu)) StMObDisposeMach(menu);
standard_hardware_clobber(menu);
menu_list = GetMenuList();
menu_list = remove_from_list(menu, menu_list);
SetMenuList(menu_list);
}
/* handle simple imperative messages with no arguments */
static LVAL simple_menu_message P1C(int, which)
{
LVAL menu;
LVAL arg = NIL;
int set = FALSE;
menu = xlgaobject();
if (which == 'E') {
if (moreargs()) {
set = TRUE;
arg = (xlgetarg() != NIL) ? s_true : NIL;
}
}
xllastarg();
switch (which) {
case 'A': StMObAllocate(menu); break;
case 'D': StMObDispose(menu); break;
case 'E': if (set) {
set_slot_value(menu, s_enabled, arg);
StMObEnable(menu, (arg != NIL));
}
return(slot_value(menu, s_enabled));
case 'I': StMObInstall(menu); break;
case 'R': StMObRemove(menu); break;
case 'U': update_menu(menu); break;
default: xlfail("unknown message");
}
return(NIL);
}
/* handle instance variable selectors/status inquiries */
static LVAL menu_selector_message P1C(int, which)
{
LVAL menu, result = NIL;
menu = xlgaobject();
xllastarg();
switch (which) {
case 'A': result = (StMObAllocated(menu)) ? s_true : NIL; break;
case 'I': result = slot_value(menu, s_items); break;
case 'i': result = (StMObInstalled(menu)) ? s_true : NIL; break;
default: xlfail("unknown message");
}
return(result);
}
/***********************************************************************/
/** **/
/** Methods **/
/** **/
/***********************************************************************/
/* :ISNEW Method */
LVAL xsmenu_isnew(V)
{
LVAL menu, title;
menu = xlgaobject();
title = xlgastring();
xllastarg();
if (strlen(getstring(title)) == 0) xlerror("title is too short", title);
object_isnew(menu);
set_slot_value(menu, s_title, title);
set_slot_value(menu, s_enabled, s_true);
return(menu);
}
LVAL xsallocate_menu(V) { return(simple_menu_message('A')); }
LVAL xsdispose_menu(V) { return(simple_menu_message('D')); }
LVAL xsupdate_menu(V) { return(simple_menu_message('U')); }
LVAL xsallocated_p(V) { return(menu_selector_message('A')); }
LVAL xsmenu_items(V) { return(menu_selector_message('I')); }
LVAL xsinstall_menu(V) { return(simple_menu_message('I')); }
LVAL xsremove_menu(V) { return(simple_menu_message('R')); }
LVAL xsinstalled_p(V) { return(menu_selector_message('i')); }
LVAL xsmenu_enabled(V) { return(simple_menu_message('E')); }
/* :APPEND-ITEMS Method */
LVAL xsappend_items(V)
{
LVAL menu, new_items;
xlsave1(new_items);
menu = xlgaobject();
new_items = makearglist(xlargc, xlargv);
append_items(menu, new_items);
xlpop();
return(NIL);
}
/* :DELETE-ITEMS Method */
LVAL xsdelete_items(V)
{
LVAL menu;
menu = xlgaobject();
while (moreargs())
delete_menu_item(menu, xlgaobject());
return(NIL);
}
/* :SELECT Method */
LVAL xsmenu_select(V)
{
LVAL menu, item=NIL, next;
int i;
menu = xsgetmenu();
i = getfixnum(xlgafixnum());
xllastarg();
for (next = slot_value(menu, s_items);
i > 1 && consp(next); i--, next = cdr(next))
;
if (! consp(next)) xlfail("no item with this index in the menu");
else item = car(next);
send_message(item, sk_do_action);
return(NIL);
}
LVAL xsmenu_title(V)
{
LVAL menu, title;
menu = xlgaobject();
if (moreargs()) {
title = xlgastring();
if (strlen(getstring(title)) == 0)
xlerror("title is too short", title);
if (StMObAllocated(menu))
xlfail("can't change title of an allocated menu");
set_slot_value(menu, s_title, title);
}
return(slot_value(menu, s_title));
}
LVAL xsmenu_popup(V)
{
LVAL menu, window;
int left, top, item;
menu = xsgetmenu();
left = getfixnum(xlgafixnum());
top = getfixnum(xlgafixnum());
window = (moreargs()) ? xlgaobject() : NIL;
xllastarg();
send_message(menu, sk_update);
item = StMObPopup(menu, left, top, window);
if (item > 0) send_message1(menu, sk_select, item);
return(cvfixnum((FIXTYPE) item));
}
/***********************************************************************/
/***********************************************************************/
/** **/
/** MENU-ITEM-PROTO Methods **/
/** **/
/***********************************************************************/
/***********************************************************************/
/***********************************************************************/
/** **/
/** Predicate and Argument Access Function **/
/** **/
/***********************************************************************/
/* is this a menu item ? */
int menu_item_p P1C(LVAL, x)
{
return(kind_of_p(x, getvalue(s_menu_item_proto)));
}
/* get and check a menu item from the argument stack */
LVAL xsgetmenuitem(V)
{
LVAL item;
item = xlgaobject();
if (! menu_item_p(item)) xlerror("not a menu item", item);
return(item);
}
/***********************************************************************/
/** **/
/** Support Function **/
/** **/
/***********************************************************************/
/* check an item instance variable */
static LVAL check_item_ivar P2C(int, which, LVAL, value)
{
int good=0;
switch (which) {
case 'T': good = (stringp(value) && strlen(getstring(value)) != 0); break;
case 'K': good = (charp(value) || value == NIL); break;
case 'M': good = (charp(value) || value == NIL || value == s_true); break;
case 'S': good = (symbolp(value) || listp(value)); break;
case 'A': good = (value == NIL || symbolp(value) || closurep(value) || subrp(value) || (bcclosurep(value))); break;
case 'E': good = TRUE; value = (value != NIL) ? s_true : NIL; break;
default: xlfail("unknown item instance variable");
}
if (! good) xlerror("bad instance variable value", value);
return(value);
}
/* set an item instance variable; item and value supplied or on the stack */
static LVAL set_item_ivar P3C(int, which, LVAL, item, LVAL, value)
{
value = check_item_ivar(which, value);
switch (which) {
case 'T': set_slot_value(item, s_title, value); break;
case 'K': set_slot_value(item, s_key, value); break;
case 'M': set_slot_value(item, s_mark, value); break;
case 'S': set_slot_value(item, s_style, value); break;
case 'A': set_slot_value(item, s_action, value); break;
case 'E': set_slot_value(item, s_enabled, value); break;
default: xlfail("unknown item instance variable");
}
StMObSetItemProp(item, which);
return(value);
}
/* get an item instance variable; item and value supplied or on the stack */
static LVAL get_item_ivar P2C(int, which, LVAL, item)
{
LVAL value=NIL;
switch (which) {
case 'T': value = slot_value(item, s_title); break;
case 'K': value = slot_value(item, s_key); break;
case 'M': value = slot_value(item, s_mark); break;
case 'S': value = slot_value(item, s_style); break;
case 'A': value = slot_value(item, s_action); break;
case 'E': value = slot_value(item, s_enabled); break;
default: xlfail("unknown item instance variable");
}
return(check_item_ivar(which, value));
}
static LVAL item_ivar P1C(int, which)
{
LVAL item;
item = xlgaobject();
if (moreargs()) set_item_ivar(which, item, xlgetarg());
return(get_item_ivar(which, item));
}
/***********************************************************************/
/** **/
/** Methods **/
/** **/
/***********************************************************************/
/* :ISNEW Method */
LVAL xsitem_isnew(V)
{
LVAL item, title, value;
item = xlgaobject();
title = xlgastring();
set_item_ivar('T', item, title);
object_isnew(item);
if (xlgetkeyarg(sk_enabled, &value)) set_item_ivar('E', item, value);
else set_item_ivar('E', item, s_true);
return(NIL); /* to keep compilers happy - L. Tierney */
}
LVAL xsitem_title(V) { return(item_ivar('T')); }
LVAL xsitem_key(V) { return(item_ivar('K')); }
LVAL xsitem_mark(V) { return(item_ivar('M')); }
LVAL xsitem_style(V) { return(item_ivar('S')); }
LVAL xsitem_action(V) { return(item_ivar('A')); }
LVAL xsitem_enabled(V) { return(item_ivar('E')); }
/* :INSTALLED-P Method */
LVAL xsitem_installed_p(V)
{
LVAL item;
item = xsgetmenuitem();
xllastarg();
return((item_installed_p(item)) ? s_true : NIL);
}
LVAL xsitem_update(V) { return(NIL); }
/* :DO-ACTION Method */
LVAL xsitem_do_action(V)
{
LVAL item, action, result;
item = xsgetmenuitem();
xllastarg();
action = slot_value(item, s_action);
result = (action != NIL) ? xlapply(pushargs(action, NIL)) : NIL;
return(result);
}
syntax highlighted by Code2HTML, v. 0.9.1