chris@umcp-cs.UUCP (Chris Torek) (08/11/85)
This ain't pretty, but. . . .
The following code stripped down from lwin.c, written by Randy Trigg
and myself. It has examples for passing back various lisp types.
After it's compiled, you use the following lispese to load it:
(cfasl 'lwin.o '_init_win_system 'init-win-system "function")
(init-win-system)
There is a University of Maryland TR on calling C code from lisp. (I
don't know the number.... does anyone in CVL have it?)
-----------------------------------------------------------------------
#include <stdio.h>
#include <sgtty.h>
#include <signal.h>
#include "global.h" /* from the lisp source */
extern lispval newdot(), inewint(), matom(), mstr(), t;
/* The errorh function causes an error to lisp with the given message printed.
* This ncerror macro will print str and cause a non-continuable error.
*/
#define ncerror(str) errorh(Vermisc,str,nil,FALSE,0)
/* Wscreensize (rows, cols)
int *rows, *cols;
Returns the number of rows & columns on the physical screen. */
lispval LWscreensize ()
{
int r,c;
register lispval dot;
Wscreensize(&r,&c);
protect(dot = newdot()); /* grab a cons node & prevent it
from being garbage collected */
dot->d.car = inewint(r); /* set car to integer, value r */
dot->d.cdr = inewint(c);
return(dot);
}
/* Wborder (w, ulc, top, urc, left, right, llc, bottom, lrc)
Win *w;
char ulc, top, urc, left, right, llc, bottom, lrc;
Borders window w with the specified characters. ulc is the upper left
corner; top is the top line, urc is the upper right corner; left is the left
side; right is the right side; llc is the lower left corner; and lrc is the
lower right corner. */
lispval LWborder ()
{
lispval ulc, top, urc, left, right, llc, bottom, lrc;
char c1,c2,c3,c4,c5,c6,c7,c8;
register lispval w;
chkarg (9, "Wborder");
w = lbot[0].val;
ulc = lbot[1].val;
top = lbot[2].val;
urc = lbot[3].val;
left = lbot[4].val;
right = lbot[5].val;
llc = lbot[6].val;
bottom = lbot[7].val;
lrc = lbot[8].val;
if (TYPE(w)!=INT) ncerror("Bad arg to 'Wborder'");
if (TYPE(ulc)==INT) c1=ulc->i;
else if (TYPE(ulc)==ATOM) c1 = *ulc->a.pname;
else if (TYPE(ulc)==STRNG) c1 = *(char *)ulc;
else ncerror("Bad arg to 'Wborder'");
if (TYPE(top)==INT) c2=top->i;
else if (TYPE(top)==ATOM) c2 = *top->a.pname;
else if (TYPE(top)==STRNG) c2 = *(char *)top;
else ncerror("Bad arg to 'Wborder'");
if (TYPE(urc)==INT) c3=urc->i;
else if (TYPE(urc)==ATOM) c3 = *urc->a.pname;
else if (TYPE(urc)==STRNG) c3 = *(char *)urc;
else ncerror("Bad arg to 'Wborder'");
if (TYPE(left)==INT) c4=left->i;
else if (TYPE(left)==ATOM) c4 = *left->a.pname;
else if (TYPE(left)==STRNG) c4 = *(char *)left;
else ncerror("Bad arg to 'Wborder'");
if (TYPE(right)==INT) c5=right->i;
else if (TYPE(right)==ATOM) c5 = *right->a.pname;
else if (TYPE(right)==STRNG) c5 = *(char *)right;
else ncerror("Bad arg to 'Wborder'");
if (TYPE(llc)==INT) c6=llc->i;
else if (TYPE(llc)==ATOM) c6 = *llc->a.pname;
else if (TYPE(llc)==STRNG) c6 = *(char *)llc;
else ncerror("Bad arg to 'Wborder'");
if (TYPE(bottom)==INT) c7=bottom->i;
else if (TYPE(bottom)==ATOM) c7 = *bottom->a.pname;
else if (TYPE(bottom)==STRNG) c7 = *(char *)bottom;
else ncerror("Bad arg to 'Wborder'");
if (TYPE(lrc)==INT) c8=lrc->i;
else if (TYPE(lrc)==ATOM) c8 = *lrc->a.pname;
else if (TYPE(lrc)==STRNG) c8 = *(char *)lrc;
else ncerror("Bad arg to 'Wborder'");
Wborder(w->i,c1,c2,c3,c4,c5,c6,c7,c8);
return(w);
}
/* Wgetframe (ulc, top, urc, left, right, llc, bottom, lrc)
char *ulc, *top, *urc, *left, *right, *llc, *bottom, *lrc;
Returns in the appropriate char * elements the default frame characters. */
lispval LWgetframe ()
{
char c[8];
static char buf[2];
register i;
register lispval dot, cdot;
Wgetframe(c,c+1,c+2,c+3,c+4,c+5,c+6,c+7);
protect(dot=cdot=newdot());
for(i=0;i<8;i++) {
buf[0]=c[i];
cdot->d.car=matom(buf);
cdot=cdot->d.cdr=(i!=7?newdot():nil);
}
return (dot);
}
/* Win *Wopen (id, xorg, yorg, xext, yext, bcols, brows)
int id, xorg, yorg, xext, yext, bcols, brows;
Returns a pointer to a new window, created with id number id, at (xorg,
yorg) on the screen, xext columns by yext rows, with a buffer at least as
big as the window but possibly larger, if bcols and/or brows are larger than
xext and yext. If the creation fails for any reason, nil is returned. */
lispval LWopen ()
{
register lispval xorg, yorg;
lispval xext, yext, bcols, brows, tmp;
chkarg (6, "Wopen");
xorg = lbot[0].val;
yorg = lbot[1].val;
xext = lbot[2].val;
yext = lbot[3].val;
bcols = lbot[4].val;
brows = lbot[5].val;
if (TYPE(xorg) != INT || TYPE(yorg) != INT
|| TYPE(xext) != INT || TYPE(yext) != INT
|| TYPE(bcols) != INT || TYPE(brows) != INT)
ncerror("Bad arg to 'Wopen'");
tmp = inewint(Wopen(0, xorg->i, yorg->i, xext->i, yext->i,
bcols->i, brows->i));
return ((int) tmp ? tmp : nil);
}
lispval LDing () { Ding(); return (tatom); }
/* many other definitions deleted */
/* example string function, untested */
lispval Lfoo () {
return (mstr("foo"));
}
/* Here we put all the C functions into the lisp system */
lispval init_win_system () {
mfun ("save-tty", Lsavetty, lambda);
mfun ("immediateon", Limmediateon, lambda);
mfun ("restore-tty", Lrestoretty, lambda);
mfun ("rawmode", Lrawmode, lambda);
mfun ("Wbox", LWbox, lambda);
mfun ("Wboxfind", LWboxfind, lambda);
mfun ("Wfind", LWfind, lambda);
mfun ("WBclear", LWBclear, lambda);
mfun ("WBclearline", LWBclearline, lambda);
mfun ("WBcursor", LWBcursor, lambda);
mfun ("WBdellines", LWBdellines, lambda);
mfun ("WBdelchars", LWBdelchars, lambda);
mfun ("WBdelcols", LWBdelcols, lambda);
mfun ("WBinschars", LWBinschars, lambda);
mfun ("WBinscols", LWBinscols, lambda);
mfun ("WBinslines", LWBinslines, lambda);
mfun ("Wscreensize", LWscreensize, lambda);
mfun ("Wsetbuf", LWsetbuf, lambda);
mfun ("Wclear", LWclear, lambda);
mfun ("Wclearline", LWclearline, lambda);
mfun ("Wclose", LWclose, lambda);
mfun ("Wauxcursor", LWauxcursor, lambda);
mfun ("WWcursor", LWWcursor, lambda);
mfun ("WWcurbegline", LWWcurbegline, lambda);
mfun ("WWcurendline", LWWcurendline, lambda);
mfun ("WAcursor", LWAcursor, lambda);
mfun ("Wrefresh", LWrefresh, lambda);
mfun ("Wfiledump", LWfiledump, lambda);
mfun ("Wborder", LWborder, lambda);
mfun ("Wframe", LWframe, lambda);
mfun ("Wgetframe", LWgetframe, lambda);
mfun ("Wsetframe", LWsetframe, lambda);
mfun ("Wsetmargins", LWsetmargins, lambda);
mfun ("Wfront", LWfront, lambda);
mfun ("Whide", LWhide, lambda);
mfun ("Wactivate", LWactivate, lambda);
mfun ("Wunhide", LWunhide, lambda);
mfun ("Wcleanup", LWcleanup, lambda);
mfun ("Winit", LWinit, lambda);
mfun ("Wsuspend", LWsuspend, lambda);
mfun ("Wdelchars", LWdelchars, lambda);
mfun ("Wdelcols", LWdelcols, lambda);
mfun ("Wdellines", LWdellines, lambda);
mfun ("Winschars", LWinschars, lambda);
mfun ("Winscols", LWinscols, lambda);
mfun ("Winslines", LWinslines, lambda);
mfun ("Wlabel", LWlabel, lambda);
mfun ("Wmove", LWmove, lambda);
mfun ("Wmoverel", LWmoverel, lambda);
mfun ("Wlink", LWlink, lambda);
mfun ("Wopen", LWopen, lambda);
mfun ("Wputs", LWputs, lambda);
mfun ("WBputs", LWBputs, lambda);
mfun ("Waputs", LWaputs, lambda);
mfun ("WBread", LWBread, lambda);
mfun ("WAread", LWAread, lambda);
mfun ("Wread", LWread, lambda);
mfun ("WBscroll", LWBscroll, lambda);
mfun ("Wrelscroll", LWrelscroll, lambda);
mfun ("Wscroll", LWscroll, lambda);
mfun ("Wscreengarbaged", LWscreengarbaged, lambda);
mfun ("Wboxoff", LWboxoff, lambda);
mfun ("Wcursorpos",LWcursorpos, lambda);
mfun ("Wacursorpos",LWacursorpos, lambda);
mfun ("Wbcursorpos",LWbcursorpos, lambda);
mfun ("Wcoords",LWcoords, lambda);
mfun ("Winsidecoords",LWinsidecoords, lambda);
mfun ("Wsetmode", LWsetmode, lambda);
mfun ("Wsetpopup", LWsetpopup, lambda);
mfun ("Wretroline", LWretroline, lambda);
mfun ("Wnewline", LWnewline, lambda);
mfun ("Woncursor", LWoncursor, lambda);
mfun ("WBtoWcursor", LWBtoWcursor, lambda);
mfun ("WWtoBcursor", LWWtoBcursor, lambda);
mfun ("Wwrap", LWwrap, lambda);
/* mfun ("Wgetlinemode", LWgetlinemode, lambda); */
mfun ("Wgetmode", LWgetmode, lambda);
mfun ("Wstatus", LWstatus, lambda);
mfun ("Wflash", LWflash, lambda);
mfun ("Ding", LDing, lambda);
mfun ("Wsetvbell", LWsetvbell, lambda);
mfun ("Wsize", LWsize, lambda);
mfun ("Wcloseall", LWcloseall, lambda);
mfun ("Wgetwstart", LWgetwstart, lambda);
mfun ("Wcurup", LWcurup, lambda);
mfun ("Wcurdown", LWcurdown, lambda);
mfun ("Wcurright", LWcurright, lambda);
mfun ("Wcurleft", LWcurleft, lambda);
mfun ("Wexit", LWexit, lambda);
return (tatom);
}
--
In-Real-Life: Chris Torek, Univ of MD Comp Sci Dept (+1 301 454 4251)
UUCP: seismo!umcp-cs!chris
CSNet: chris@umcp-cs ARPA: chris@maryland