/* $Id: ncguile.c,v 1.1 2000/06/18 04:33:09 rlb Exp $ */ /* * Author: Klaus Schilling * * Subject: guile-bindings for curses * To: guile@cygnus.com * Date: Wed, 12 Aug 1998 22:48:10 +0200 (MET DST) */ /* GNU GPL stuff gets here */ #include #include #include #include long win_tag; SCM win2scm (WINDOW *); WINDOW *scm2win (SCM); SCM win_mark (SCM); scm_sizet win_die (SCM); /*int win_print (SCM, SCM, scm_print_state *); */ scm_smobfuns win_funs; /* Jaffer uses ptobs (port objects) which use additional routines that are easily created from ncurses routines. Is it possible to forge soft ports from window smobs instead, when the port facilities are needed? */ void WINDOW_type_init (void); SCM s_initscr (void); SCM s_newwin (SCM, SCM, SCM, SCM); SCM s_subwin (SCM, SCM, SCM, SCM, SCM); SCM s_derwin (SCM, SCM, SCM, SCM, SCM); SCM s_dupwin (SCM); SCM s_newpad (SCM, SCM); SCM s_mvwin (SCM, SCM, SCM); SCM s_mvderwin (SCM, SCM, SCM); SCM s_delwin (SCM); SCM s_endwin (void); SCM s_isendwin (void); SCM s_wnoutrefresh (SCM); SCM s_pnoutrefresh (SCM, SCM, SCM, SCM, SCM, SCM, SCM); SCM s_doupdate (void); SCM s_redrawwin (SCM); SCM s_wredrawln (SCM, SCM, SCM); SCM s_wmove (SCM, SCM, SCM); SCM s_waddnstr (SCM, SCM, SCM); SCM s_winsnstr (SCM, SCM, SCM); SCM s_keypad (SCM, SCM); SCM s_meta (SCM, SCM); SCM s_nodelay (SCM, SCM); SCM s_intrflush (SCM, SCM); SCM s_qiflush (void); SCM s_noqiflush (void); SCM s_wgetch (SCM); SCM s_ungetch (SCM); SCM s_cbreak (void); SCM s_nocbreak (void); SCM s_echo (void); SCM s_noecho (void); SCM s_nl (void); SCM s_nonl (void); SCM s_halfdelay (SCM); SCM s_raw (void); SCM s_noraw (void); SCM s_clearok (SCM, SCM); SCM s_idlok (SCM, SCM); SCM s_leaveok (SCM, SCM); SCM s_scrollok (SCM, SCM); SCM s_idcok (SCM, SCM); SCM s_immedok (SCM, SCM); SCM s_beep (void); SCM s_flash (void); SCM s_werase (SCM); SCM s_wclear (SCM); SCM s_wclrtobot (SCM); SCM s_wclrtoeol (SCM); SCM s_winsdelln (SCM, SCM); SCM s_getcurx (SCM); SCM s_getcury (SCM); SCM s_getbegx (SCM); SCM s_getbegy (SCM); SCM s_getmaxx (SCM); SCM s_getmaxy (SCM); SCM s_getparx (SCM); SCM s_getpary (SCM); SCM s_baudrate (void); SCM s_wscrl (SCM, SCM); SCM s_wtouchln (SCM, SCM, SCM, SCM); SCM s_copywin (SCM, SCM, SCM, SCM, SCM, SCM, SCM, SCM, SCM); void guile_ncurses_init (void); /* conversion functions SCM <-> WINDOW */ SCM win2scm (WINDOW * win) { SCM scm; if (win == NULL) return SCM_BOOL_F; SCM_NEWCELL (scm); SCM_SETCAR (scm, win_tag); SCM_SETCDR (scm, win); return scm; } WINDOW * scm2win (SCM obj) { WINDOW *result; SCM_ASSERT (SCM_NIMP (obj) && (SCM_CAR (obj) == win_tag), obj, SCM_ARG3, "scm2win"); result = (WINDOW *) SCM_CDR (obj); return result; } /* smobfuns for WINDOW type */ SCM win_mark (SCM obj) { WINDOW *win; win = (WINDOW *) SCM_CDR (obj); /* SCM_SETGC8MARK (win); now obsolete ? */ if (_SUBWIN & ((win)->_flags)) { SCM_SETGC8MARK (win2scm ((win)->_parent)); } return SCM_BOOL_F; } /* Jaffer doesn't enforce marking parent windows of subwindows. Wonder if there's something else that prevents orphanization of windows */ scm_sizet win_die (SCM obj) { WINDOW *win; win = (WINDOW *) SCM_CDR (obj); if ((win == stdscr) || (win == curscr)) { return 0; } /* do not garbage collect stdscr or curscr */ return ((delwin (win) == ERR) ? 0 : sizeof (WINDOW)); /* Jaffer lets always return 0 , wonder why */ } scm_smobfuns win_funs = {win_mark, win_die, 0, 0}; void WINDOW_type_init () { win_tag = scm_newsmob (&win_funs); } /* wrapping some functions from */ SCM s_initscr () { gh_defer_ints (); initscr (); gh_allow_ints (); gh_define ("stdscr", win2scm (stdscr)); gh_define ("curscr", win2scm (curscr)); return win2scm (stdscr); } SCM s_newwin (SCM ls, SCM cs, SCM ys, SCM xs) { WINDOW *win; int l, c, y, x; l = gh_scm2long (ls); c = gh_scm2long (cs); y = gh_scm2long (ys); x = gh_scm2long (xs); gh_defer_ints (); win = newwin (l, c, y, x); gh_allow_ints (); return win2scm (win); } SCM s_subwin (SCM obj, SCM ls, SCM cs, SCM ys, SCM xs) { WINDOW *win, *owin; int l, c, y, x; owin = scm2win (obj); l = gh_scm2long (ls); c = gh_scm2long (cs); y = gh_scm2long (ys); x = gh_scm2long (xs); gh_defer_ints (); win = subwin (owin, l, c, y, x); gh_allow_ints (); return win2scm (win); } SCM s_derwin (SCM obj, SCM ls, SCM cs, SCM ys, SCM xs) { WINDOW *win, *owin; int l, c, y, x; owin = scm2win (obj); l = gh_scm2long (ls); c = gh_scm2long (cs); y = gh_scm2long (ys); x = gh_scm2long (xs); gh_defer_ints (); win = derwin (owin, l, c, y, x); gh_allow_ints (); return win2scm (win); } SCM s_dupwin (SCM obj) { WINDOW *owin, *win; owin = scm2win (obj); gh_defer_ints (); win = dupwin (owin); gh_allow_ints (); return win2scm (win); } SCM s_newpad (SCM ls, SCM cs) { WINDOW *win; int l, c; l = gh_scm2long (ls); c = gh_scm2long (cs); gh_defer_ints (); win = newpad (l, c); gh_allow_ints (); return win2scm (win); } SCM s_subpad (SCM obj, SCM ls, SCM cs, SCM ys, SCM xs) { WINDOW *win, *owin; int l, c, y, x; owin = scm2win (obj); l = gh_scm2long (ls); c = gh_scm2long (cs); y = gh_scm2long (ys); x = gh_scm2long (xs); gh_defer_ints (); win = subpad (owin, l, c, y, x); gh_allow_ints (); return win2scm (win); } SCM s_mvwin (SCM obj, SCM ys, SCM xs) { WINDOW *win; int success, y, x; win = scm2win (obj); y = gh_scm2long (ys); x = gh_scm2long (xs); gh_defer_ints (); success = mvwin (win, y, x); gh_allow_ints (); return gh_int2scm (success); } SCM s_mvderwin (SCM obj, SCM ys, SCM xs) { WINDOW *win; int success, y, x; win = scm2win (obj); y = gh_scm2long (ys); x = gh_scm2long (xs); gh_defer_ints (); success = mvderwin (win, y, x); gh_allow_ints (); return gh_int2scm (success); } SCM s_delwin (SCM obj) { WINDOW *win; int success; win = scm2win (obj); gh_defer_ints (); success = delwin (win); gh_allow_ints (); return gh_int2scm (success); } SCM s_endwin () { int success; gh_defer_ints (); success = endwin (); gh_allow_ints (); return gh_int2scm (success); } SCM s_isendwin () { int result; gh_defer_ints (); result = isendwin (); gh_allow_ints (); return gh_bool2scm (result); /* gh_int2scmb (result) bei guile-1.2 */ } SCM s_wnoutrefresh (SCM obj) { WINDOW *win; int success; win = scm2win (obj); gh_defer_ints (); success = wnoutrefresh (win); gh_allow_ints (); return gh_int2scm (success); } SCM s_pnoutrefresh (SCM obj, SCM as, SCM bs, SCM cs, SCM ds, SCM es, SCM fs) { WINDOW *win; int a, b, c, d, e, f; int success; win = scm2win (obj); a = gh_scm2long (as); b = gh_scm2long (bs); c = gh_scm2long (cs); d = gh_scm2long (ds); e = gh_scm2long (es); f = gh_scm2long (fs); gh_defer_ints (); success = pnoutrefresh (win, a, b, c, d, e, f); gh_allow_ints (); return gh_int2scm (success); } SCM s_doupdate () { int success; gh_defer_ints (); success = doupdate (); gh_allow_ints (); return gh_int2scm (success); } SCM s_redrawwin (SCM obj) { WINDOW *win; int success; win = scm2win (obj); gh_defer_ints (); success = redrawwin (win); gh_allow_ints (); return gh_int2scm (success); } SCM s_wredrawln (SCM obj, SCM start, SCM amount) { WINDOW *win; int s, n; int success; win = scm2win (obj); n = gh_scm2long (amount); s = gh_scm2long (start); gh_defer_ints (); success = wredrawln (win, s, n); gh_allow_ints (); return gh_int2scm (success); } SCM s_wmove (SCM obj, SCM ys, SCM xs) { WINDOW *win; int y, x, success; win = scm2win (obj); y = gh_scm2long (ys); x = gh_scm2long (xs); gh_defer_ints (); success = wmove (win, y, x); gh_allow_ints (); return gh_int2scm (success); } SCM s_waddnstr (SCM obj, SCM str, SCM ns) { WINDOW *win; int n, success; char *string; win = scm2win (obj); n = gh_scm2long (ns); string = gh_scm2newstr (str, 0); gh_defer_ints (); success = waddnstr (win, string, n); gh_allow_ints (); free (string); return gh_int2scm (success); } SCM s_winsnstr (SCM obj, SCM str, SCM ns) { WINDOW *win; int n, success; char *string; win = scm2win (obj); n = gh_scm2long (ns); string = gh_scm2newstr (str, 0); gh_defer_ints (); success = winsnstr (win, string, n); gh_allow_ints (); free (string); return gh_int2scm (success); } SCM s_keypad (SCM obj, SCM sflag) { WINDOW *win; int flag; int success; win = scm2win (obj); flag = gh_scm2bool (sflag); gh_defer_ints (); success = keypad (win, flag); gh_allow_ints (); return gh_int2scm (success); } SCM s_meta (SCM obj, SCM sflag) { WINDOW *win; int flag; int success; win = scm2win (obj); flag = gh_scm2bool (sflag); gh_defer_ints (); success = meta (win, flag); gh_allow_ints (); return gh_int2scm (success); } SCM s_intrflush (SCM obj, SCM sflag) { WINDOW *win; int flag; int success; win = scm2win (obj); flag = gh_scm2bool (sflag); gh_defer_ints (); success = intrflush (win, flag); gh_allow_ints (); return gh_int2scm (success); } SCM s_nodelay (SCM obj, SCM sflag) { WINDOW *win; int flag; int success; win = scm2win (obj); flag = gh_scm2bool (sflag); gh_defer_ints (); success = nodelay (win, flag); gh_allow_ints (); return gh_int2scm (success); } SCM s_qiflush () { gh_defer_ints (); qiflush (); gh_allow_ints (); return SCM_UNSPECIFIED; } SCM s_noqiflush () { gh_defer_ints (); noqiflush (); gh_allow_ints (); return SCM_UNSPECIFIED; } SCM s_wgetch (SCM obj) { WINDOW *win; int result; win = scm2win (obj); gh_defer_ints (); result = wgetch (win); gh_allow_ints (); return gh_int2scm (result); } SCM s_ungetch (SCM key) { int success; int k = gh_scm2long (key); gh_defer_ints (); success = ungetch (k); gh_allow_ints (); return gh_int2scm (success); } SCM s_cbreak () { int success; gh_defer_ints (); success = cbreak (); gh_allow_ints (); return gh_int2scm (success); } SCM s_nocbreak () { int success; gh_defer_ints (); success = nocbreak (); gh_allow_ints (); return gh_int2scm (success); } SCM s_echo () { int success; gh_defer_ints (); success = echo (); gh_allow_ints (); return gh_int2scm (success); } SCM s_noecho () { int success; gh_defer_ints (); success = noecho (); gh_allow_ints (); return gh_int2scm (success); } SCM s_nl () { int success; gh_defer_ints (); success = nl (); gh_defer_ints (); return gh_int2scm (success); } SCM s_nonl () { int success; gh_defer_ints (); success = nonl (); gh_allow_ints (); return gh_int2scm (success); } SCM s_halfdelay (SCM dec) { int d; int success; d = gh_scm2long (dec); gh_defer_ints (); success = halfdelay (d); gh_allow_ints (); return gh_int2scm (success); } SCM s_raw () { int success; gh_defer_ints (); success = raw (); gh_allow_ints (); return gh_int2scm (success); } SCM s_noraw () { int success; gh_defer_ints (); success = noraw (); gh_allow_ints (); return gh_int2scm (success); } SCM s_clearok (SCM obj, SCM sflag) { WINDOW *win; int flag; int success; win = scm2win (obj); flag = gh_scm2bool (sflag); gh_defer_ints (); success = clearok (win, flag); gh_allow_ints (); return gh_int2scm (success); } SCM s_idlok (SCM obj, SCM sflag) { WINDOW *win; int flag; int success; win = scm2win (obj); flag = gh_scm2bool (sflag); gh_defer_ints (); success = idlok (win, flag); gh_allow_ints (); return gh_int2scm (success); } SCM s_leaveok (SCM obj, SCM sflag) { WINDOW *win; int flag; int success; win = scm2win (obj); flag = gh_scm2bool (sflag); gh_defer_ints (); success = leaveok (win, flag); gh_allow_ints (); return gh_int2scm (success); } SCM s_scrollok (SCM obj, SCM sflag) { WINDOW *win; int flag; int success; win = scm2win (obj); flag = gh_scm2bool (sflag); gh_defer_ints (); success = scrollok (win, flag); gh_allow_ints (); return gh_int2scm (success); } SCM s_idcok (SCM obj, SCM sflag) { WINDOW *win; int flag; win = scm2win (obj); flag = gh_scm2bool (sflag); gh_defer_ints (); idcok (win, flag); gh_allow_ints (); return SCM_UNSPECIFIED; } SCM s_immedok (SCM obj, SCM sflag) { WINDOW *win; int flag; win = scm2win (obj); flag = gh_scm2bool (sflag); gh_defer_ints (); immedok (win, flag); gh_allow_ints (); return SCM_UNSPECIFIED; } SCM s_beep () { int success; gh_defer_ints (); success = beep (); gh_allow_ints (); return gh_int2scm (success); } SCM s_flash () { int success; gh_defer_ints (); success = flash (); gh_allow_ints (); return gh_int2scm (success); } SCM s_werase (SCM obj) { WINDOW *win; int success; win = scm2win (obj); gh_defer_ints (); success = werase (win); gh_allow_ints (); return gh_int2scm (success); } SCM s_wclear (SCM obj) { WINDOW *win; int success; win = scm2win (obj); gh_defer_ints (); success = wclear (win); gh_allow_ints (); return gh_int2scm (success); } SCM s_wclrtobot (SCM obj) { WINDOW *win; int success; win = scm2win (obj); gh_defer_ints (); success = wclrtobot (win); gh_allow_ints (); return gh_int2scm (success); } SCM s_wclrtoeol (SCM obj) { WINDOW *win; int success; win = scm2win (obj); gh_defer_ints (); success = wclrtoeol (win); gh_allow_ints (); return gh_int2scm (success); } SCM s_winsdelln (SCM obj, SCM amount) { WINDOW *win; int n = gh_scm2long (amount); int success; win = scm2win (obj); gh_defer_ints (); success = winsdelln (win, n); gh_allow_ints (); return gh_int2scm (success); } SCM s_getcurx (SCM obj) { WINDOW *win; int result; win = scm2win (obj); gh_defer_ints (); result = win->_curx; gh_allow_ints (); return gh_int2scm (result); } SCM s_getcury (SCM obj) { WINDOW *win; int result; win = scm2win (obj); gh_defer_ints (); result = win->_cury; gh_allow_ints (); return gh_int2scm (result); } SCM s_getbegx (SCM obj) { WINDOW *win; int result; win = scm2win (obj); gh_defer_ints (); result = win->_begx; gh_allow_ints (); return gh_int2scm (result); } SCM s_getbegy (SCM obj) { WINDOW *win; int result; win = scm2win (obj); gh_defer_ints (); result = win->_begy; gh_allow_ints (); return gh_int2scm (result); } SCM s_getmaxx (SCM obj) { WINDOW *win; int result; win = scm2win (obj); gh_defer_ints (); result = win->_maxx; gh_allow_ints (); return gh_int2scm (result); } SCM s_getmaxy (SCM obj) { WINDOW *win; int result; win = scm2win (obj); gh_defer_ints (); result = win->_maxy; gh_allow_ints (); return gh_int2scm (result); } SCM s_getparx (SCM obj) { WINDOW *win; int result; win = scm2win (obj); gh_defer_ints (); result = win->_parx; gh_allow_ints (); return gh_int2scm (result); } SCM s_getpary (SCM obj) { WINDOW *win; int result; win = scm2win (obj); gh_defer_ints (); result = win->_pary; gh_allow_ints (); return gh_int2scm (result); } SCM s_baudrate () { int result; gh_defer_ints (); result = baudrate (); gh_allow_ints (); return gh_int2scm (result); } SCM s_wscrl (SCM obj, SCM amount) { WINDOW *win; int n = gh_scm2long (amount); int success; win = scm2win (obj); gh_defer_ints (); success = wscrl (win, n); gh_allow_ints (); return gh_int2scm (success); } SCM s_wtouchln (SCM obj, SCM ys, SCM ns, SCM sflag) { WINDOW *win; int y, n, flag; int result; win = scm2win (obj); y = gh_scm2long (ys); n = gh_scm2long (ns); flag = gh_scm2bool (sflag); gh_defer_ints (); result = wtouchln (win, y, n, flag); gh_allow_ints (); return gh_int2scm (result); } SCM s_copywin (SCM source, SCM destiny, SCM sirs, SCM sics, SCM dirs, SCM dics, SCM dars, SCM dacs, SCM sflag) { WINDOW *source_win; WINDOW *destiny_win; int sir, sic, dir, dic, dar, dac; int flag; int success; source_win = scm2win (source); destiny_win = scm2win (destiny); sir = gh_scm2long (sirs); sic = gh_scm2long (sics); dir = gh_scm2long (dirs); dic = gh_scm2long (dics); dar = gh_scm2long (dars); dac = gh_scm2long (dacs); flag = gh_scm2bool (sflag); gh_defer_ints (); success = copywin (source_win, destiny_win, sir, sic, dir, dic, dar, dac, flag); gh_allow_ints (); return gh_int2scm (success); } void guile_ncurses_init () { WINDOW_type_init (); gh_define ("ERR", gh_int2scm (ERR)); gh_define ("OK", gh_int2scm (OK)); gh_new_procedure ("initscr", s_initscr, 0, 0, 0); gh_new_procedure ("newwin", s_newwin, 4, 0, 0); gh_new_procedure ("subwin", s_subwin, 5, 0, 0); gh_new_procedure ("derwin", s_derwin, 5, 0, 0); gh_new_procedure ("dupwin", s_dupwin, 1, 0, 0); gh_new_procedure ("newpad", s_newpad, 2, 0, 0); gh_new_procedure ("subpad", s_subpad, 5, 0, 0); gh_new_procedure ("mvwin", s_mvwin, 3, 0, 0); gh_new_procedure ("mvderwin", s_mvderwin, 3, 0, 0); gh_new_procedure ("delwin", s_delwin, 1, 0, 0); gh_new_procedure ("endwin", s_endwin, 0, 0, 0); gh_new_procedure ("isendwin", s_isendwin, 0, 0, 0); gh_new_procedure ("wnoutrefresh", s_wnoutrefresh, 1, 0, 0); gh_new_procedure ("pnoutrefresh", s_pnoutrefresh, 7, 0, 0); gh_new_procedure ("doupdate", s_doupdate, 0, 0, 0); gh_new_procedure ("redrawwin", s_redrawwin, 1, 0, 0); gh_new_procedure ("wredrawln", s_wredrawln, 3, 0, 0); gh_new_procedure ("wmove", s_wmove, 3, 0, 0); gh_new_procedure ("waddnstr", s_waddnstr, 3, 0, 0); gh_new_procedure ("winsnstr", s_winsnstr, 3, 0, 0); gh_new_procedure ("keypad", s_keypad, 2, 0, 0); gh_new_procedure ("meta", s_meta, 2, 0, 0); gh_new_procedure ("intrflush", s_intrflush, 2, 0, 0); gh_new_procedure ("nodelay", s_nodelay, 2, 0, 0); gh_new_procedure ("qiflush", s_qiflush, 0, 0, 0); gh_new_procedure ("noqiflush", s_noqiflush, 0, 0, 0); gh_new_procedure ("wgetch", s_wgetch, 1, 0, 0); gh_new_procedure ("ungetch", s_ungetch, 1, 0, 0); gh_new_procedure ("cbreak", s_cbreak, 0, 0, 0); gh_new_procedure ("nocbreak", s_nocbreak, 0, 0, 0); gh_new_procedure ("echo", s_echo, 0, 0, 0); gh_new_procedure ("noecho", s_noecho, 0, 0, 0); gh_new_procedure ("nl", s_nl, 0, 0, 0); gh_new_procedure ("nonl", s_nonl, 0, 0, 0); gh_new_procedure ("halfdelay", s_halfdelay, 1, 0, 0); gh_new_procedure ("raw", s_raw, 0, 0, 0); gh_new_procedure ("noraw", s_noraw, 0, 0, 0); gh_new_procedure ("clearok", s_clearok, 2, 0, 0); gh_new_procedure ("idlok", s_idlok, 2, 0, 0); gh_new_procedure ("leaveok", s_leaveok, 2, 0, 0); gh_new_procedure ("scrollok", s_scrollok, 2, 0, 0); gh_new_procedure ("idcok", s_idcok, 2, 0, 0); gh_new_procedure ("immedok", s_immedok, 2, 0, 0); gh_new_procedure ("beep", s_beep, 0, 0, 0); gh_new_procedure ("flash", s_flash, 0, 0, 0); gh_new_procedure ("werase", s_werase, 1, 0, 0); gh_new_procedure ("wclear", s_wclear, 1, 0, 0); gh_new_procedure ("wclrtobot", s_wclrtobot, 1, 0, 0); gh_new_procedure ("wclrtoeol", s_wclrtoeol, 1, 0, 0); gh_new_procedure ("winsdelln", s_winsdelln, 2, 0, 0); gh_new_procedure ("getcurx", s_getcurx, 1, 0, 0); gh_new_procedure ("getcury", s_getcury, 1, 0, 0); gh_new_procedure ("getmaxx", s_getcurx, 1, 0, 0); gh_new_procedure ("getmaxy", s_getcury, 1, 0, 0); gh_new_procedure ("getbegx", s_getcurx, 1, 0, 0); gh_new_procedure ("getbegy", s_getcury, 1, 0, 0); gh_new_procedure ("getparx", s_getcurx, 1, 0, 0); gh_new_procedure ("getpary", s_getcury, 1, 0, 0); gh_new_procedure ("baudrate", s_baudrate, 0, 0, 0); gh_new_procedure ("wscrl", s_wscrl, 2, 0, 0); gh_new_procedure ("wtouchln", s_wtouchln, 4, 0, 0); gh_new_procedure ("copywin", s_copywin, 9, 0, 0); } /* Debugger interface (don't change the order of the following lines) */ #define GDB_TYPE SCM #include GDB_INTERFACE; static void inner_main (void *closure, int argc, char **argv) { /* module initializations would go here */ guile_ncurses_init (); scm_shell (argc, argv); } int main (int argc, char **argv) { scm_boot_guile (argc, argv, inner_main, 0); return 0; /* never reached */ }