LispObj *
Lisp_XDefaultRootWindow(LispBuiltin *builtin)
/*
x-default-root-window display
*/
{
LispObj *display;
display = ARGUMENT(0);
if (!CHECKO(display, x11Display_t))
LispDestroy("%s: cannot convert %s to Display*",
STRFUN(builtin), STROBJ(display));
return (OPAQUE(DefaultRootWindow((Display*)(display->data.opaque.data)),
x11Window_t));
}
/*
Helper function, so that it is not required to redirect error output
*/
LispObj *
Lisp_PipeErrorStream(LispBuiltin *builtin)
/*
pipe-error-stream pipe-stream
*/
{
LispObj *pipe_stream;
pipe_stream = ARGUMENT(0);
if (!STREAMP(pipe_stream) ||
pipe_stream->data.stream.type != LispStreamPipe)
LispDestroy("%s: %s is not a pipe stream",
STRFUN(builtin), STROBJ(pipe_stream));
return (pipe_stream->data.stream.source.program->errorp);
}
LispObj *
Lisp_IntChar(LispBuiltin *builtin)
/*
int-char integer
code-char integer
*/
{
long character = 0;
LispObj *integer;
integer = ARGUMENT(0);
CHECK_FIXNUM(integer);
character = FIXNUM_VALUE(integer);
return (character >= 0 && character < 0xff ? SCHAR(character) : NIL);
}
bool Parser::OPTARG(int& pos)
{
int p{ pos };
OptionValue ovalue;
if (OPTION(p, ovalue))
{
pos = p;
return true;
}
ArgumentValue avalue;
if (ARGUMENT(p, avalue))
{
pos = p;
return true;
}
return false;
}
LispObj *
Lisp_XCloseDisplay(LispBuiltin *builtin)
/*
x-close-display display
*/
{
LispObj *display;
display = ARGUMENT(0);
if (!CHECKO(display, x11Display_t))
LispDestroy("%s: cannot convert %s to Display*",
STRFUN(builtin), STROBJ(display));
XCloseDisplay((Display*)(display->data.opaque.data));
return (NIL);
}
LispObj *
Lisp_XawListUnhighlight(LispBuiltin *builtin)
/*
xaw-list-unhighlight widget
*/
{
LispObj *owidget;
owidget = ARGUMENT(0);
if (!CHECKO(owidget, xawWidget_t))
LispDestroy("%s: cannot convert %s to Widget",
STRFUN(builtin), STROBJ(owidget));
XawListUnhighlight((Widget)(owidget->data.opaque.data));
return (NIL);
}
LispObj *
Lisp_PQerrorMessage(LispBuiltin *builtin)
{
char *string;
PGconn *conn;
LispObj *connection;
connection = ARGUMENT(0);
if (!CHECKO(connection, PGconn_t))
LispDestroy("%s: cannot convert %s to PGconn*",
STRFUN(builtin), STROBJ(connection));
conn = (PGconn*)(connection->data.opaque.data);
string = PQerrorMessage(conn);
return (string ? STRING(string) : NIL);
}
static LispObj *
LispCharOp(LispBuiltin *builtin, int operation)
{
int value;
LispObj *result, *character;
character = ARGUMENT(0);
CHECK_SCHAR(character);
value = (int)SCHAR_VALUE(character);
switch (operation) {
case CHAR_ALPHAP:
result = isalpha(value) ? T : NIL;
break;
case CHAR_DOWNCASE:
result = SCHAR(tolower(value));
break;
case CHAR_UPCASE:
result = SCHAR(toupper(value));
break;
case CHAR_INT:
result = FIXNUM(value);
break;
case CHAR_BOTHP:
result = isupper(value) || islower(value) ? T : NIL;
break;
case CHAR_UPPERP:
result = isupper(value) ? T : NIL;
break;
case CHAR_LOWERP:
result = islower(value) ? T : NIL;
break;
case CHAR_GRAPHICP:
result = value == ' ' || isgraph(value) ? T : NIL;
break;
default:
result = NIL;
break;
}
return (result);
}
/*
Helper function, primarily for use with the xt module
*/
LispObj *
Lisp_PipeErrorDescriptor(LispBuiltin *builtin)
/*
pipe-error-descriptor pipe-stream
*/
{
LispObj *pipe_stream;
pipe_stream = ARGUMENT(0);
if (!STREAMP(pipe_stream) ||
pipe_stream->data.stream.type != LispStreamPipe)
LispDestroy("%s: %s is not a pipe stream",
STRFUN(builtin), STROBJ(pipe_stream));
if (!EPSTREAMP(pipe_stream))
LispDestroy("%s: pipe %s is closed",
STRFUN(builtin), STROBJ(pipe_stream));
return (INTEGER(LispFileno(EPSTREAMP(pipe_stream))));
}
/*
Helper function, primarily for use with the xt module
*/
LispObj *
Lisp_PipeInputDescriptor(LispBuiltin *builtin)
/*
pipe-input-descriptor pipe-stream
*/
{
LispObj *pipe_stream;
pipe_stream = ARGUMENT(0);
if (!STREAMP(pipe_stream) ||
pipe_stream->data.stream.type != LispStreamPipe)
LispDestroy("%s: %s is not a pipe stream",
STRFUN(builtin), STROBJ(pipe_stream));
if (!IPSTREAMP(pipe_stream))
LispDestroy("%s: pipe %s is unreadable",
STRFUN(builtin), STROBJ(pipe_stream));
return (INTEGER(LispFileno(IPSTREAMP(pipe_stream))));
}
LispObj *
Lisp_XOpenDisplay(LispBuiltin *builtin)
/*
x-open-display &optional display-name
*/
{
LispObj *display_name;
char *dname;
display_name = ARGUMENT(0);
if (display_name == UNSPEC)
dname = NULL;
else {
CHECK_STRING(display_name);
dname = THESTR(display_name);
}
return (OPAQUE(XOpenDisplay(dname), x11Display_t));
}
LispObj *
Lisp_PQclear(LispBuiltin *builtin)
/*
pq-clear result
*/
{
PGresult *res;
LispObj *result;
result = ARGUMENT(0);
if (!CHECKO(result, PGresult_t))
LispDestroy("%s: cannot convert %s to PGresult*",
STRFUN(builtin), STROBJ(result));
res = (PGresult*)(result->data.opaque.data);
PQclear(res);
return (NIL);
}
LispObj *
Lisp_PQfinish(LispBuiltin *builtin)
/*
pq-finish connection
*/
{
PGconn *conn;
LispObj *connection;
connection = ARGUMENT(0);
if (!CHECKO(connection, PGconn_t))
LispDestroy("%s: cannot convert %s to PGconn*",
STRFUN(builtin), STROBJ(connection));
conn = (PGconn*)(connection->data.opaque.data);
PQfinish(conn);
return (NIL);
}
LispObj *
Lisp_XFlush(LispBuiltin *builtin)
/*
x-flush display
*/
{
Display *display;
LispObj *odisplay;
odisplay = ARGUMENT(0);
if (!CHECKO(odisplay, x11Display_t))
LispDestroy("%s: cannot convert %s to Display*",
STRFUN(builtin), STROBJ(odisplay));
display = (Display*)(odisplay->data.opaque.data);
XFlush(display);
return (odisplay);
}
LispObj *
Lisp_PQbackendPID(LispBuiltin *builtin)
/*
pq-backend-pid connection
*/
{
int pid;
PGconn *conn;
LispObj *connection;
connection = ARGUMENT(0);
if (!CHECKO(connection, PGconn_t))
LispDestroy("%s: cannot convert %s to PGconn*",
STRFUN(builtin), STROBJ(connection));
conn = (PGconn*)(connection->data.opaque.data);
pid = PQbackendPID(conn);
return (INTEGER(pid));
}
LispObj *
Lisp_PQconsumeInput(LispBuiltin *builtin)
/*
pq-consume-input connection
*/
{
int result;
PGconn *conn;
LispObj *connection;
connection = ARGUMENT(0);
if (!CHECKO(connection, PGconn_t))
LispDestroy("%s: cannot convert %s to PGconn*",
STRFUN(builtin), STROBJ(connection));
conn = (PGconn*)(connection->data.opaque.data);
result = PQconsumeInput(conn);
return (INTEGER(result));
}
LispObj *
Lisp_XawScrollbarCoerceToReal(LispBuiltin *builtin)
/*
xaw-scrollbar-coerce-to-real opaque
*/
{
float *floatp;
double real;
LispObj *opaque;
opaque = ARGUMENT(0);
if (!CHECKO(opaque, xawFloatp_t))
LispDestroy("%s: cannot convert %s to float*",
STRFUN(builtin), STROBJ(opaque));
floatp = (float*)(opaque->data.opaque.data);
real = *floatp;
return (DFLOAT(real));
}
LispObj *
Lisp_PQresultStatus(LispBuiltin *builtin)
/*
pq-result-status result
*/
{
int status;
PGresult *res;
LispObj *result;
result = ARGUMENT(0);
if (!CHECKO(result, PGresult_t))
LispDestroy("%s: cannot convert %s to PGresult*",
STRFUN(builtin), STROBJ(result));
res = (PGresult*)(result->data.opaque.data);
status = PQresultStatus(res);
return (INTEGER(status));
}
LispObj *
Lisp_PQstatus(LispBuiltin *builtin)
/*
pq-status connection
*/
{
int status;
PGconn *conn;
LispObj *connection;
connection = ARGUMENT(0);
if (!CHECKO(connection, PGconn_t))
LispDestroy("%s: cannot convert %s to PGconn*",
STRFUN(builtin), STROBJ(connection));
conn = (PGconn*)(connection->data.opaque.data);
status = PQstatus(conn);
return (INTEGER(status));
}
LispObj *
Lisp_PQnotifies(LispBuiltin *builtin)
/*
pq-notifies connection
*/
{
LispObj *result, *code, *cod = COD;
PGconn *conn;
PGnotify *notifies;
LispObj *connection;
connection = ARGUMENT(0);
if (!CHECKO(connection, PGconn_t))
LispDestroy("%s: cannot convert %s to PGconn*",
STRFUN(builtin), STROBJ(connection));
conn = (PGconn*)(connection->data.opaque.data);
if ((notifies = PQnotifies(conn)) == NULL)
return (NIL);
GCDisable();
code = CONS(ATOM("MAKE-PG-NOTIFY"),
CONS(KEYWORD("RELNAME"),
CONS(STRING(notifies->relname),
CONS(KEYWORD("BE-PID"),
CONS(REAL(notifies->be_pid), NIL)))));
COD = CONS(code, COD);
GCEnable();
result = EVAL(code);
COD = cod;
free(notifies);
return (result);
}
LispObj *
Lisp_StringConcat(LispBuiltin *builtin)
/*
string-concat &rest strings
*/
{
char *buffer;
long size, length;
LispObj *object, *string;
LispObj *strings;
strings = ARGUMENT(0);
if (strings == NIL)
return (STRING(""));
for (length = 1, object = strings; CONSP(object); object = CDR(object)) {
string = CAR(object);
CHECK_STRING(string);
length += STRLEN(string);
}
buffer = LispMalloc(length);
for (length = 0, object = strings; CONSP(object); object = CDR(object)) {
string = CAR(object);
size = STRLEN(string);
memcpy(buffer + length, THESTR(string), size);
length += size;
}
buffer[length] = '\0';
object = LSTRING2(buffer, length);
return (object);
}
LispObj *
Lisp_MakeStringOutputStream(LispBuiltin *builtin)
/*
make-string-output-stream &key element-type
*/
{
LispObj *element_type;
element_type = ARGUMENT(0);
if (element_type != UNSPEC) {
/* just check argument... */
if (SYMBOLP(element_type) && ATOMID(element_type) == Scharacter)
; /* do nothing */
else if (KEYWORDP(element_type) &&
ATOMID(element_type) == Sdefault)
; /* do nothing */
else
LispDestroy("%s: only :%s and %s supported for :ELEMENT-TYPE, not %s",
STRFUN(builtin), Sdefault, Scharacter, STROBJ(element_type));
}
return (LSTRINGSTREAM("", STREAM_WRITE, 1));
}
LispObj *
Lisp_XawListChange(LispBuiltin *builtin)
/*
xaw-list-change widget list &optional longest resize
*/
{
Widget widget;
String *list;
int i, nitems;
int longest;
Boolean resize;
LispObj *object;
WidgetData *data;
LispObj *owidget, *olist, *olongest, *oresize;
oresize = ARGUMENT(3);
olongest = ARGUMENT(2);
olist = ARGUMENT(1);
owidget = ARGUMENT(0);
if (!CHECKO(owidget, xawWidget_t))
LispDestroy("%s: cannot convert %s to Widget",
STRFUN(builtin), STROBJ(owidget));
widget = (Widget)(owidget->data.opaque.data);
CHECK_LIST(olist);
for (nitems = 0, object = olist; CONSP(object);
++nitems, object = CDR(object))
CHECK_STRING(CAR(object));
if (olongest != UNSPEC) {
CHECK_INDEX(olongest);
longest = FIXNUM_VALUE(olongest);
}
else
XtVaGetValues(widget, XtNlongest, &longest, NULL, 0);
resize = oresize != UNSPEC && oresize != NIL;
/* No errors in arguments, build string list */
list = (String*)XtMalloc(sizeof(String) * nitems);
for (i = 0, object = olist; CONSP(object); i++, object = CDR(object))
list[i] = THESTR(CAR(object));
/* Check if xaw-list-change was already called
* for this widget and free previous data */
for (i = 0; i < num_list_data; i++)
if ((Widget)CAR(list_data[i]->object)->data.opaque.data == widget) {
XtRemoveCallback(widget, XtNdestroyCallback,
LispXawCleanupCallback, list_data[i]);
LispXawCleanupCallback(widget, list_data[i], NULL);
break;
}
if (i >= num_list_data) {
++num_list_data;
list_data = (WidgetData**)XtRealloc((XtPointer)list_data,
sizeof(WidgetData*) * num_list_data);
}
data = (WidgetData*)XtMalloc(sizeof(WidgetData));
data->data = list;
list_data[i] = data;
data->object = CONS(owidget, olist);
PROTECT(owidget, data->object);
XtAddCallback(widget, XtNdestroyCallback, LispXawCleanupCallback, data);
XawListChange(widget, list, nitems, longest, resize);
return (olist);
}
LispObj *
Lisp_Reexec(LispBuiltin *builtin)
/*
re-exec regex string &key count start end notbol noteol
*/
{
size_t nmatch;
re_mat match[10];
long start, end, length;
int code, cflags, eflags;
char *string;
LispObj *result;
re_cod *regexp;
LispObj *regex, *ostring, *count, *ostart, *oend, *notbol, *noteol;
noteol = ARGUMENT(6);
notbol = ARGUMENT(5);
oend = ARGUMENT(4);
ostart = ARGUMENT(3);
count = ARGUMENT(2);
ostring = ARGUMENT(1);
regex = ARGUMENT(0);
if (STRINGP(regex))
regexp = LispRecomp(builtin, THESTR(regex), cflags = 0);
else {
CHECK_REGEX(regex);
regexp = regex->data.regex.regex;
cflags = regex->data.regex.options;
}
CHECK_STRING(ostring);
if (count == UNSPEC)
nmatch = 1;
else {
CHECK_INDEX(count);
nmatch = FIXNUM_VALUE(count);
if (nmatch > 10)
LispDestroy("%s: COUNT cannot be larger than 10", STRFUN(builtin));
}
if (nmatch && (cflags & RE_NOSUB))
nmatch = 1;
eflags = RE_STARTEND;
if (notbol != UNSPEC && notbol != NIL)
eflags |= RE_NOTBOL;
if (noteol != UNSPEC && noteol != NIL)
eflags |= RE_NOTEOL;
string = THESTR(ostring);
LispCheckSequenceStartEnd(builtin, ostring, ostart, oend,
&start, &end, &length);
match[0].rm_so = start;
match[0].rm_eo = end;
code = reexec(regexp, string, nmatch, &match[0], eflags);
if (code == 0) {
if (nmatch && match[0].rm_eo >= match[0].rm_so) {
result = CONS(CONS(FIXNUM(match[0].rm_so),
FIXNUM(match[0].rm_eo)), NIL);
if (nmatch > 1 && match[1].rm_eo >= match[1].rm_so) {
int i;
GC_ENTER();
LispObj *cons = result;
GC_PROTECT(result);
for (i = 1;
i < nmatch && match[i].rm_eo >= match[i].rm_so;
i++) {
RPLACD(cons, CONS(CONS(FIXNUM(match[i].rm_so),
FIXNUM(match[i].rm_eo)), NIL));
cons = CDR(cons);
}
GC_LEAVE();
}
}
else
result = NIL;
}
else
result = Knomatch;
/* Maybe shoud cache compiled regex, but better the caller do it */
if (!XREGEXP(regex)) {
refree(regexp);
LispFree(regexp);
}
return (result);
}
LispObj *
Lisp_XCreateSimpleWindow(LispBuiltin *builtin)
/*
x-create-simple-window display parent x y width height &optional border-width border background
*/
{
Display *display;
Window parent;
int x, y;
unsigned int width, height, border_width;
unsigned long border, background;
LispObj *odisplay, *oparent, *ox, *oy, *owidth, *oheight,
*oborder_width, *oborder, *obackground;
obackground = ARGUMENT(8);
oborder = ARGUMENT(7);
oborder_width = ARGUMENT(6);
oheight = ARGUMENT(5);
owidth = ARGUMENT(4);
oy = ARGUMENT(3);
ox = ARGUMENT(2);
oparent = ARGUMENT(1);
odisplay = ARGUMENT(0);
if (!CHECKO(odisplay, x11Display_t))
LispDestroy("%s: cannot convert %s to Display*",
STRFUN(builtin), STROBJ(odisplay));
display = (Display*)(odisplay->data.opaque.data);
if (!CHECKO(oparent, x11Window_t))
LispDestroy("%s: cannot convert %s to Window",
STRFUN(builtin), STROBJ(oparent));
parent = (Window)(oparent->data.opaque.data);
CHECK_FIXNUM(ox);
x = FIXNUM_VALUE(ox);
CHECK_FIXNUM(oy);
y = FIXNUM_VALUE(oy);
CHECK_INDEX(owidth);
width = FIXNUM_VALUE(owidth);
CHECK_INDEX(oheight);
height = FIXNUM_VALUE(oheight);
/* check &OPTIONAL parameters */
if (oborder_width == UNSPEC)
border_width = 1;
else {
CHECK_INDEX(oborder_width);
border_width = FIXNUM_VALUE(oborder_width);
}
if (oborder == UNSPEC)
border = BlackPixel(display, DefaultScreen(display));
else {
CHECK_LONGINT(oborder);
border = LONGINT_VALUE(oborder);
}
if (obackground == UNSPEC)
background = WhitePixel(display, DefaultScreen(display));
else {
CHECK_LONGINT(obackground);
background = LONGINT_VALUE(obackground);
}
return (OPAQUE(
XCreateSimpleWindow(display, parent, x, y, width, height,
border_width, border, background),
x11Window_t));
}
LispObj *
Lisp_Open(LispBuiltin *builtin)
/*
open filename &key direction element-type if-exists if-does-not-exist external-format
*/
{
GC_ENTER();
char *string;
LispObj *stream = NIL;
int mode, flags, direction, exist, noexist, file_exist;
LispFile *file;
LispObj *filename, *odirection, *element_type, *if_exists,
*if_does_not_exist, *external_format;
external_format = ARGUMENT(5);
if_does_not_exist = ARGUMENT(4);
if_exists = ARGUMENT(3);
element_type = ARGUMENT(2);
odirection = ARGUMENT(1);
filename = ARGUMENT(0);
if (STRINGP(filename)) {
filename = APPLY1(Oparse_namestring, filename);
GC_PROTECT(filename);
}
else if (STREAMP(filename)) {
if (filename->data.stream.type != LispStreamFile)
LispDestroy("%s: %s is not a FILE-STREAM",
STRFUN(builtin), STROBJ(filename));
filename = filename->data.stream.pathname;
}
else {
CHECK_PATHNAME(filename);
}
if (odirection != UNSPEC) {
direction = -1;
if (KEYWORDP(odirection)) {
if (odirection == Kprobe)
direction = DIR_PROBE;
else if (odirection == Kinput)
direction = DIR_INPUT;
else if (odirection == Koutput)
direction = DIR_OUTPUT;
else if (odirection == Kio)
direction = DIR_IO;
}
if (direction == -1)
LispDestroy("%s: bad :DIRECTION %s",
STRFUN(builtin), STROBJ(odirection));
}
else
direction = DIR_INPUT;
if (element_type != UNSPEC) {
/* just check argument... */
if (SYMBOLP(element_type) &&
ATOMID(element_type) == Scharacter)
; /* do nothing */
else if (KEYWORDP(element_type) &&
ATOMID(element_type) == Sdefault)
; /* do nothing */
else
LispDestroy("%s: only :%s and %s supported for :ELEMENT-TYPE, not %s",
STRFUN(builtin), Sdefault, Scharacter, STROBJ(element_type));
}
if (if_exists != UNSPEC) {
exist = -1;
if (if_exists == NIL)
exist = EXT_NIL;
else if (KEYWORDP(if_exists)) {
if (if_exists == Kerror)
exist = EXT_ERROR;
else if (if_exists == Knew_version)
exist = EXT_NEW_VERSION;
else if (if_exists == Krename)
exist = EXT_RENAME;
else if (if_exists == Krename_and_delete)
exist = EXT_RENAME_DELETE;
else if (if_exists == Koverwrite)
exist = EXT_OVERWRITE;
else if (if_exists == Kappend)
exist = EXT_APPEND;
else if (if_exists == Ksupersede)
exist = EXT_SUPERSEDE;
}
if (exist == -1)
LispDestroy("%s: bad :IF-EXISTS %s",
STRFUN(builtin), STROBJ(if_exists));
}
else
exist = EXT_ERROR;
if (if_does_not_exist != UNSPEC) {
noexist = -1;
if (if_does_not_exist == NIL)
noexist = NOEXT_NIL;
if (KEYWORDP(if_does_not_exist)) {
if (if_does_not_exist == Kerror)
noexist = NOEXT_ERROR;
else if (if_does_not_exist == Kcreate)
noexist = NOEXT_CREATE;
}
if (noexist == -1)
LispDestroy("%s: bad :IF-DOES-NO-EXISTS %s",
STRFUN(builtin), STROBJ(if_does_not_exist));
}
else
noexist = direction != DIR_INPUT ? NOEXT_NOTHING : NOEXT_ERROR;
if (external_format != UNSPEC) {
/* just check argument... */
if (SYMBOLP(external_format) &&
ATOMID(external_format) == Scharacter)
; /* do nothing */
else if (KEYWORDP(external_format) &&
ATOMID(external_format) == Sdefault)
; /* do nothing */
else
LispDestroy("%s: only :%s and %s supported for :EXTERNAL-FORMAT, not %s",
STRFUN(builtin), Sdefault, Scharacter, STROBJ(external_format));
}
/* string representation of pathname */
string = THESTR(CAR(filename->data.pathname));
mode = 0;
file_exist = access(string, F_OK) == 0;
if (file_exist) {
if (exist == EXT_NIL) {
GC_LEAVE();
return (NIL);
}
}
else {
if (noexist == NOEXT_NIL) {
GC_LEAVE();
return (NIL);
}
if (noexist == NOEXT_ERROR)
LispDestroy("%s: file %s does not exist",
STRFUN(builtin), STROBJ(CAR(filename->data.quote)));
else if (noexist == NOEXT_CREATE) {
LispFile *tmp = LispFopen(string, FILE_WRITE);
if (tmp)
LispFclose(tmp);
else
LispDestroy("%s: cannot create file %s",
STRFUN(builtin),
STROBJ(CAR(filename->data.quote)));
}
}
if (direction == DIR_OUTPUT || direction == DIR_IO) {
if (file_exist) {
if (exist == EXT_ERROR)
LispDestroy("%s: file %s already exists",
STRFUN(builtin), STROBJ(CAR(filename->data.quote)));
if (exist == EXT_RENAME) {
/* Add an ending '~' at the end of the backup file */
char tmp[PATH_MAX + 1];
strcpy(tmp, string);
if (strlen(tmp) + 1 > PATH_MAX)
LispDestroy("%s: backup name for %s too long",
STRFUN(builtin),
STROBJ(CAR(filename->data.quote)));
strcat(tmp, "~");
if (rename(string, tmp))
LispDestroy("%s: rename: %s",
STRFUN(builtin), strerror(errno));
mode |= FILE_WRITE;
}
else if (exist == EXT_OVERWRITE)
mode |= FILE_WRITE;
else if (exist == EXT_APPEND)
mode |= FILE_APPEND;
}
else
mode |= FILE_WRITE;
if (direction == DIR_IO)
mode |= FILE_IO;
}
else
mode |= FILE_READ;
file = LispFopen(string, mode);
if (file == NULL)
LispDestroy("%s: open: %s", STRFUN(builtin), strerror(errno));
flags = 0;
if (direction == DIR_PROBE) {
LispFclose(file);
file = NULL;
}
else {
if (direction == DIR_INPUT || direction == DIR_IO)
flags |= STREAM_READ;
if (direction == DIR_OUTPUT || direction == DIR_IO)
flags |= STREAM_WRITE;
}
stream = FILESTREAM(file, filename, flags);
GC_LEAVE();
return (stream);
}
LispObj *
LispPQsetdb(LispBuiltin *builtin, int loginp)
/*
pq-setdb host port options tty dbname
pq-setdb-login host port options tty dbname login password
*/
{
PGconn *conn;
char *host, *port, *options, *tty, *dbname, *login, *password;
LispObj *ohost, *oport, *ooptions, *otty, *odbname, *ologin, *opassword;
if (loginp) {
opassword = ARGUMENT(6);
ologin = ARGUMENT(5);
}
else
opassword = ologin = NIL;
odbname = ARGUMENT(4);
otty = ARGUMENT(3);
ooptions = ARGUMENT(2);
oport = ARGUMENT(1);
ohost = ARGUMENT(0);
if (ohost != NIL) {
CHECK_STRING(ohost);
host = THESTR(ohost);
}
else
host = NULL;
if (oport != NIL) {
CHECK_STRING(oport);
port = THESTR(oport);
}
else
port = NULL;
if (ooptions != NIL) {
CHECK_STRING(ooptions);
options = THESTR(ooptions);
}
else
options = NULL;
if (otty != NIL) {
CHECK_STRING(otty);
tty = THESTR(otty);
}
else
tty = NULL;
if (odbname != NIL) {
CHECK_STRING(odbname);
dbname = THESTR(odbname);
}
else
dbname = NULL;
if (ologin != NIL) {
CHECK_STRING(ologin);
login = THESTR(ologin);
}
else
login = NULL;
if (opassword != NIL) {
CHECK_STRING(opassword);
password = THESTR(opassword);
}
else
password = NULL;
conn = PQsetdbLogin(host, port, options, tty, dbname, login, password);
return (conn ? OPAQUE(conn, PGconn_t) : NIL);
}
LispObj *
Lisp_PQgetvalue(LispBuiltin *builtin)
/*
pq-getvalue result tuple field &optional type-specifier
*/
{
char *string;
double real = 0.0;
PGresult *res;
int tuple, field, isint = 0, isreal = 0, integer;
LispObj *result, *otupple, *field_number, *type;
type = ARGUMENT(3);
field_number = ARGUMENT(2);
otupple = ARGUMENT(1);
result = ARGUMENT(0);
if (!CHECKO(result, PGresult_t))
LispDestroy("%s: cannot convert %s to PGresult*",
STRFUN(builtin), STROBJ(result));
res = (PGresult*)(result->data.opaque.data);
CHECK_INDEX(otupple);
tuple = FIXNUM_VALUE(otupple);
CHECK_INDEX(field_number);
field = FIXNUM_VALUE(field_number);
string = PQgetvalue(res, tuple, field);
if (type != UNSPEC) {
char *typestring;
CHECK_SYMBOL(type);
typestring = ATOMID(type);
if (strcmp(typestring, "INT16") == 0) {
integer = *(short*)string;
isint = 1;
goto simple_type;
}
else if (strcmp(typestring, "INT32") == 0) {
integer = *(int*)string;
isint = 1;
goto simple_type;
}
else if (strcmp(typestring, "FLOAT") == 0) {
real = *(float*)string;
isreal = 1;
goto simple_type;
}
else if (strcmp(typestring, "REAL") == 0) {
real = *(double*)string;
isreal = 1;
goto simple_type;
}
else if (strcmp(typestring, "PG-POLYGON") == 0)
goto polygon_type;
else if (strcmp(typestring, "STRING") != 0)
LispDestroy("%s: unknown type %s",
STRFUN(builtin), typestring);
}
simple_type:
return (isint ? INTEGER(integer) : isreal ? DFLOAT(real) :
(string ? STRING(string) : NIL));
polygon_type:
{
LispObj *poly, *box, *p = NIL, *cdr, *obj;
POLYGON *polygon;
int i, size;
size = PQgetlength(res, tuple, field);
polygon = (POLYGON*)(string - sizeof(int));
GCDisable();
/* get polygon->boundbox */
cdr = EVAL(CONS(ATOM("MAKE-PG-POINT"),
CONS(KEYWORD("X"),
CONS(REAL(polygon->boundbox.high.x),
CONS(KEYWORD("Y"),
CONS(REAL(polygon->boundbox.high.y), NIL))))));
obj = EVAL(CONS(ATOM("MAKE-PG-POINT"),
CONS(KEYWORD("X"),
CONS(REAL(polygon->boundbox.low.x),
CONS(KEYWORD("Y"),
CONS(REAL(polygon->boundbox.low.y), NIL))))));
box = EVAL(CONS(ATOM("MAKE-PG-BOX"),
CONS(KEYWORD("HIGH"),
CONS(cdr,
CONS(KEYWORD("LOW"),
CONS(obj, NIL))))));
/* get polygon->p values */
for (i = 0; i < polygon->npts; i++) {
obj = EVAL(CONS(ATOM("MAKE-PG-POINT"),
CONS(KEYWORD("X"),
CONS(REAL(polygon->p[i].x),
CONS(KEYWORD("Y"),
CONS(REAL(polygon->p[i].y), NIL))))));
if (i == 0)
p = cdr = CONS(obj, NIL);
else {
RPLACD(cdr, CONS(obj, NIL));
cdr = CDR(cdr);
}
}
/* make result */
poly = EVAL(CONS(ATOM("MAKE-PG-POLYGON"),
CONS(KEYWORD("SIZE"),
CONS(REAL(size),
CONS(KEYWORD("NUM-POINTS"),
CONS(REAL(polygon->npts),
CONS(KEYWORD("BOUNDBOX"),
CONS(box,
CONS(KEYWORD("POINTS"),
CONS(QUOTE(p), NIL))))))))));
GCEnable();
return (poly);
}
}
/* XXX Non standard functions below
*/
LispObj *
Lisp_MakePipe(LispBuiltin *builtin)
/*
make-pipe command-line &key :direction :element-type :external-format
*/
{
char *string;
LispObj *stream = NIL;
int flags, direction;
LispFile *error_file;
LispPipe *program;
int ifd[2];
int ofd[2];
int efd[2];
char *argv[4];
LispObj *command_line, *odirection, *element_type, *external_format;
external_format = ARGUMENT(3);
element_type = ARGUMENT(2);
odirection = ARGUMENT(1);
command_line = ARGUMENT(0);
if (PATHNAMEP(command_line))
command_line = CAR(command_line->data.quote);
else if (!STRINGP(command_line))
LispDestroy("%s: %s is a bad pathname",
STRFUN(builtin), STROBJ(command_line));
if (odirection != UNSPEC) {
direction = -1;
if (KEYWORDP(odirection)) {
if (odirection == Kprobe)
direction = DIR_PROBE;
else if (odirection == Kinput)
direction = DIR_INPUT;
else if (odirection == Koutput)
direction = DIR_OUTPUT;
else if (odirection == Kio)
direction = DIR_IO;
}
if (direction == -1)
LispDestroy("%s: bad :DIRECTION %s",
STRFUN(builtin), STROBJ(odirection));
}
else
direction = DIR_INPUT;
if (element_type != UNSPEC) {
/* just check argument... */
if (SYMBOLP(element_type) && ATOMID(element_type) == Scharacter)
; /* do nothing */
else if (KEYWORDP(element_type) && ATOMID(element_type) == Sdefault)
; /* do nothing */
else
LispDestroy("%s: only :%s and %s supported for :ELEMENT-TYPE, not %s",
STRFUN(builtin), Sdefault, Scharacter, STROBJ(element_type));
}
if (external_format != UNSPEC) {
/* just check argument... */
if (SYMBOLP(external_format) && ATOMID(external_format) == Scharacter)
; /* do nothing */
else if (KEYWORDP(external_format) &&
ATOMID(external_format) == Sdefault)
; /* do nothing */
else
LispDestroy("%s: only :%s and %s supported for :EXTERNAL-FORMAT, not %s",
STRFUN(builtin), Sdefault, Scharacter, STROBJ(external_format));
}
string = THESTR(command_line);
program = LispMalloc(sizeof(LispPipe));
if (direction != DIR_PROBE) {
argv[0] = "sh";
argv[1] = "-c";
argv[2] = string;
argv[3] = NULL;
pipe(ifd);
pipe(ofd);
pipe(efd);
if ((program->pid = fork()) == 0) {
close(0);
close(1);
close(2);
dup2(ofd[0], 0);
dup2(ifd[1], 1);
dup2(efd[1], 2);
close(ifd[0]);
close(ifd[1]);
close(ofd[0]);
close(ofd[1]);
close(efd[0]);
close(efd[1]);
execve("/bin/sh", argv, environ);
exit(-1);
}
else if (program->pid < 0)
LispDestroy("%s: fork: %s", STRFUN(builtin), strerror(errno));
program->input = LispFdopen(ifd[0], FILE_READ | FILE_UNBUFFERED);
close(ifd[1]);
program->output = LispFdopen(ofd[1], FILE_WRITE | FILE_UNBUFFERED);
close(ofd[0]);
error_file = LispFdopen(efd[0], FILE_READ | FILE_UNBUFFERED);
close(efd[1]);
}
else {
program->pid = -1;
program->input = program->output = error_file = NULL;
}
flags = direction == DIR_PROBE ? 0 : STREAM_READ;
program->errorp = FILESTREAM(error_file, command_line, flags);
flags = 0;
if (direction != DIR_PROBE) {
if (direction == DIR_INPUT || direction == DIR_IO)
flags |= STREAM_READ;
if (direction == DIR_OUTPUT || direction == DIR_IO)
flags |= STREAM_WRITE;
}
stream = PIPESTREAM(program, command_line, flags);
LispMused(program);
return (stream);
}
LispObj *
Lisp_Require(LispBuiltin *builtin)
/*
require module &optional pathname
*/
{
char filename[1024], *ext;
int len;
LispObj *obj, *module, *pathname;
pathname = ARGUMENT(1);
module = ARGUMENT(0);
CHECK_STRING(module);
if (pathname != UNSPEC) {
if (PATHNAMEP(pathname))
pathname = CAR(pathname->data.pathname);
else {
CHECK_STRING(pathname);
}
}
else
pathname = module;
for (obj = MOD; CONSP(obj); obj = CDR(obj)) {
if (strcmp(THESTR(CAR(obj)), THESTR(module)) == 0)
return (module);
}
if (THESTR(pathname)[0] != '/') {
#ifdef LISPDIR
snprintf(filename, sizeof(filename), "%s", LISPDIR);
#else
getcwd(filename, sizeof(filename));
#endif
}
else
filename[0] = '\0';
*(filename + sizeof(filename) - 5) = '\0'; /* make sure there is place for ext */
len = strlen(filename);
if (!len || filename[len - 1] != '/') {
strcat(filename, "/");
++len;
}
snprintf(filename + len, sizeof(filename) - len - 5, "%s", THESTR(pathname));
ext = filename + strlen(filename);
#ifdef SHARED_MODULES
strcpy(ext, ".so");
if (access(filename, R_OK) == 0) {
LispModule *lisp_module;
char data[64];
int len;
if (lisp__data.module == NULL) {
/* export our own symbols */
if (dlopen(NULL, RTLD_LAZY | RTLD_GLOBAL) == NULL)
LispDestroy("%s: ", STRFUN(builtin), dlerror());
}
lisp_module = (LispModule*)LispMalloc(sizeof(LispModule));
if ((lisp_module->handle =
dlopen(filename, RTLD_LAZY | RTLD_GLOBAL)) == NULL)
LispDestroy("%s: dlopen: %s", STRFUN(builtin), dlerror());
snprintf(data, sizeof(data), "%sLispModuleData", THESTR(module));
if ((lisp_module->data =
(LispModuleData*)dlsym(lisp_module->handle, data)) == NULL) {
dlclose(lisp_module->handle);
LispDestroy("%s: cannot find LispModuleData for %s",
STRFUN(builtin), STROBJ(module));
}
LispMused(lisp_module);
lisp_module->next = lisp__data.module;
lisp__data.module = lisp_module;
if (lisp_module->data->load)
(lisp_module->data->load)();
if (MOD == NIL)
MOD = CONS(module, NIL);
else {
RPLACD(MOD, CONS(CAR(MOD), CDR(MOD)));
RPLACA(MOD, module);
}
LispSetVar(lisp__data.modules, MOD);
return (module);
}
#endif
strcpy(ext, ".lsp");
(void)LispLoadFile(STRING(filename), 0, 0, 0);
return (module);
}
