Пример #1
0
LispObj *
Lisp_RenameFile(LispBuiltin *builtin)
/*
 rename-file filename new-name
 */
{
    int code;
    GC_ENTER();
    char *from, *to;
    LispObj *old_truename, *new_truename;

    LispObj *filename, *new_name;

    new_name = 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);
    }
    old_truename = APPLY1(Otruename, filename);
    GC_PROTECT(old_truename);

    if (STRINGP(new_name)) {
	new_name = APPLY3(Oparse_namestring, new_name, NIL, filename);
	GC_PROTECT(new_name);
    }
    else {
	CHECK_PATHNAME(new_name);
    }

    from = THESTR(CAR(filename->data.pathname));
    to = THESTR(CAR(new_name->data.pathname));
    code = LispRename(from, to);
    if (code)
	LispDestroy("%s: rename(%s, %s): %s",
		    STRFUN(builtin), from, to, strerror(errno));
    GC_LEAVE();

    new_truename = APPLY1(Otruename, new_name);
    RETURN_COUNT = 2;
    RETURN(0) = old_truename;
    RETURN(1) = new_truename;

    return (new_name);
}
Пример #2
0
LispObj *
Lisp_DeleteFile(LispBuiltin *builtin)
/*
 delete-file filename
 */
{
    GC_ENTER();
    LispObj *filename;

    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);
    }
    GC_LEAVE();

    return (LispUnlink(THESTR(CAR(filename->data.pathname))) ? NIL : T);
}
Пример #3
0
Файл: psql.c Проект: aosm/X11
LispObj *
Lisp_PQfnumber(LispBuiltin *builtin)
/*
 pq-fnumber result field-name
 */
{
    int number;
    int field;
    PGresult *res;

    LispObj *result, *field_name;

    field_name = 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_STRING(field_name);
    number = PQfnumber(res, THESTR(field_name));

    return (INTEGER(number));
}
Пример #4
0
Файл: string.c Проект: 8l/xedit
/* helper function for setf
 *	DONT explicitly call. Non standard function
 */
LispObj *
Lisp_XeditCharStore(LispBuiltin *builtin)
/*
 xedit::char-store string index value
 */
{
    int character;
    long offset, length;
    LispObj *ostring, *oindex, *ovalue;

    ovalue = ARGUMENT(2);
    oindex = ARGUMENT(1);
    ostring = ARGUMENT(0);

    CHECK_STRING(ostring);
    CHECK_INDEX(oindex);
    length = STRLEN(ostring);
    offset = FIXNUM_VALUE(oindex);
    if (offset >= length)
	LispDestroy("%s: index %ld too large for string length %ld",
		    STRFUN(builtin), offset, length);
    CHECK_SCHAR(ovalue);
    CHECK_STRING_WRITABLE(ostring);

    character = SCHAR_VALUE(ovalue);

    if (character < 0 || character > 255)
	LispDestroy("%s: cannot represent character %d",
		    STRFUN(builtin), character);

    THESTR(ostring)[offset] = character;

    return (ovalue);
}
Пример #5
0
Файл: string.c Проект: 8l/xedit
LispObj *
Lisp_Char(LispBuiltin *builtin)
/*
 char string index
 schar simple-string index
 */
{
    unsigned char *string;
    long offset, length;

    LispObj *ostring, *oindex;

    oindex = ARGUMENT(1);
    ostring = ARGUMENT(0);

    CHECK_STRING(ostring);
    CHECK_INDEX(oindex);
    offset = FIXNUM_VALUE(oindex);
    string = (unsigned char*)THESTR(ostring);
    length = STRLEN(ostring);

    if (offset >= length)
	LispDestroy("%s: index %ld too large for string length %ld",
		    STRFUN(builtin), offset, length);

    return (SCHAR(string[offset]));
}
Пример #6
0
Файл: xaw.c Проект: aosm/X11
LispObj *
Lisp_XawTextSearch(LispBuiltin *builtin)
/*
 xaw-text-search widget direction text
 */
{
    Widget widget;
    XawTextScanDirection direction;
    XawTextBlock block;

    LispObj *owidget, *odirection, *otext;

    otext = ARGUMENT(2);
    odirection = 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_INDEX(odirection);
    direction = (XawTextPosition)FIXNUM_VALUE(odirection);
    if (direction != XawsdLeft && direction != XawsdRight)
	LispDestroy("%s: %d does not fit in XawTextScanDirection",
		    STRFUN(builtin), direction);

    CHECK_STRING(otext);
    block.firstPos = 0;
    block.ptr = THESTR(otext);
    block.length = strlen(block.ptr);
    block.format = FMT8BIT;

    return (FIXNUM(XawTextSearch(widget, direction, &block)));
}
Пример #7
0
LispObj *
Lisp_MakeStringInputStream(LispBuiltin *builtin)
/*
 make-string-input-stream string &optional start end
 */
{
    char *string;
    long start, end, length;

    LispObj *ostring, *ostart, *oend, *result;

    oend = ARGUMENT(2);
    ostart = ARGUMENT(1);
    ostring = ARGUMENT(0);

    start = end = 0;
    CHECK_STRING(ostring);
    LispCheckSequenceStartEnd(builtin, ostring, ostart, oend,
			      &start, &end, &length);
    string = THESTR(ostring);

    if (end - start != length)
	length = end - start;
    result = LSTRINGSTREAM(string + start, STREAM_READ, length);

    return (result);
}
Пример #8
0
Файл: package.c Проект: 8l/xedit
LispObj *
LispFindPackageFromString(const char *string)
{
    LispObj *list, *package, *nick;

    for (list = PACK; CONSP(list); list = CDR(list)) {
	package = CAR(list);
	if (strcmp(THESTR(package->data.package.name), string) == 0)
	    return (package);
	for (nick = package->data.package.nicknames;
	     CONSP(nick); nick = CDR(nick))
	    if (strcmp(THESTR(CAR(nick)), string) == 0)
		return (package);
    }

    return (NIL);
}
Пример #9
0
Файл: string.c Проект: 8l/xedit
LispObj *
LispStringUpcase(LispBuiltin *builtin, int inplace)
/*
 string-upcase string &key start end
 nstring-upcase string &key start end
 */
{
    LispObj *result;
    char *string, *newstring;
    long start, end, length, offset;

    LispObj *ostring, *ostart, *oend;

    oend = ARGUMENT(2);
    ostart = ARGUMENT(1);
    ostring = ARGUMENT(0);
    CHECK_STRING(ostring);
    LispCheckSequenceStartEnd(builtin, ostring, ostart, oend,
			      &start, &end, &offset);
    result = ostring;
    string = THESTR(ostring);
    length = STRLEN(ostring);

    /* first check if something need to be done */
    for (offset = start; offset < end; offset++)
	if (string[offset] != toupper(string[offset]))
	    break;

    if (offset >= end)
	return (result);

    if (inplace) {
	CHECK_STRING_WRITABLE(ostring);
	newstring = string;
    }
    else {
	/* upcase a copy of argument */
	newstring = LispMalloc(length + 1);
	if (offset)
	    memcpy(newstring, string, offset);
	if (length > end)
	    memcpy(newstring + end, string + end, length - end);
	newstring[length] = '\0';
    }

    for (; offset < end; offset++)
	newstring[offset] = toupper(string[offset]);

    if (!inplace)
	result = LSTRING2(newstring, length);

    return (result);
}
Пример #10
0
Файл: string.c Проект: 8l/xedit
/* XXX preserve-whitespace is being ignored */
LispObj *
Lisp_ReadFromString(LispBuiltin *builtin)
/*
 read-from-string string &optional eof-error-p eof-value &key start end preserve-whitespace
 */
{
    GC_ENTER();
    char *string;
    LispObj *stream, *result;
    long length, start, end, bytes_read;

    LispObj *ostring, *eof_error_p, *eof_value, *ostart, *oend;

    oend = ARGUMENT(4);
    ostart = ARGUMENT(3);
    eof_value = ARGUMENT(2);
    eof_error_p = ARGUMENT(1);
    ostring = ARGUMENT(0);

    CHECK_STRING(ostring);
    string = THESTR(ostring);
    LispCheckSequenceStartEnd(builtin, ostring, ostart, oend,
			      &start, &end, &length);

    if (start > 0 || end < length)
	length = end - start;
    stream = LSTRINGSTREAM(string + start, STREAM_READ, length);

    if (eof_value == UNSPEC)
	eof_value = NIL;

    LispPushInput(stream);
    result = LispRead();
    /* stream->data.stream.source.string->input is
     * the offset of the last byte read in string */
    bytes_read = stream->data.stream.source.string->input;
    LispPopInput(stream);

    if (result == NULL) {
	if (eof_error_p == NIL)
	    result = eof_value;
	else
	    LispDestroy("%s: unexpected end of input", STRFUN(builtin));
    }

    GC_PROTECT(result);
    RETURN(0) = FIXNUM(start + bytes_read);
    RETURN_COUNT = 1;
    GC_LEAVE();

    return (result);
}
Пример #11
0
Файл: package.c Проект: 8l/xedit
LispObj *
LispFindPackage(LispObj *name)
{
    char *string = NULL;

    if (PACKAGEP(name))
	return (name);

    if (SYMBOLP(name))
	string = ATOMID(name)->value;
    else if (STRINGP(name))
	string = THESTR(name);
    else
	LispDestroy("FIND-PACKAGE: %s is not a string or symbol", STROBJ(name));

    return (LispFindPackageFromString(string));
}
Пример #12
0
Файл: regex.c Проект: 8l/xedit
LispObj *
Lisp_Recomp(LispBuiltin *builtin)
/*
 re-comp pattern &key nospec icase nosub newline
 */
{
    re_cod *regex;
    int cflags = 0;

    LispObj *result;

    LispObj *pattern, *nospec, *icase, *nosub, *newline;

    newline = ARGUMENT(4);
    nosub = ARGUMENT(3);
    icase = ARGUMENT(2);
    nospec = ARGUMENT(1);
    pattern = ARGUMENT(0);

    /* Don't generate an error if it is already a compiled regex. */
    if (REGEXP(pattern))
	return (pattern);

    CHECK_STRING(pattern);

    if (nospec != UNSPEC && nospec != NIL)
	cflags |= RE_NOSPEC;
    if (icase != UNSPEC && icase != NIL)
	cflags |= RE_ICASE;
    if (nosub != UNSPEC && nosub != NIL)
	cflags |= RE_NOSUB;
    if (newline != UNSPEC && newline != NIL)
	cflags |= RE_NEWLINE;

    regex = LispRecomp(builtin, THESTR(pattern), cflags);
    result = LispNew(pattern, NIL);
    result->type = LispRegex_t;
    result->data.regex.regex = regex;
    result->data.regex.pattern = pattern;
    result->data.regex.options = cflags;
    LispMused(regex);

    return (result);
}
Пример #13
0
Файл: x11.c Проект: aosm/X11
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));
}
Пример #14
0
Файл: string.c Проект: 8l/xedit
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);
}
Пример #15
0
Файл: xaw.c Проект: aosm/X11
LispObj *
Lisp_XawTextReplace(LispBuiltin *builtin)
/*
 xaw-text-replace widget left right text
 */
{
    Widget widget;
    XawTextPosition left, right;
    XawTextBlock block;

    LispObj *owidget, *oleft, *oright, *otext;

    otext = ARGUMENT(3);
    oright = ARGUMENT(2);
    oleft = 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_INDEX(oleft);
    left = (XawTextPosition)FIXNUM_VALUE(oleft);

    CHECK_INDEX(oright);
    right = (XawTextPosition)FIXNUM_VALUE(oright);

    CHECK_STRING(otext);
    block.firstPos = 0;
    block.ptr = THESTR(otext);
    block.length = strlen(block.ptr);
    block.format = FMT8BIT;

    return (FIXNUM(XawTextReplace(widget, left, right, &block)));
}
Пример #16
0
Файл: psql.c Проект: aosm/X11
LispObj *
Lisp_PQexec(LispBuiltin *builtin)
/*
 pq-exec connection query
 */
{
    PGconn *conn;
    PGresult *res;

    LispObj *connection, *query;

    query = ARGUMENT(1);
    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);

    CHECK_STRING(query);
    res = PQexec(conn, THESTR(query));

    return (res ? OPAQUE(res, PGresult_t) : NIL);
}
Пример #17
0
Файл: xaw.c Проект: aosm/X11
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);
}
Пример #18
0
Файл: psql.c Проект: aosm/X11
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);
}
Пример #19
0
Файл: string.c Проект: 8l/xedit
LispObj *
Lisp_ParseInteger(LispBuiltin *builtin)
/*
 parse-integer string &key start end radix junk-allowed
 */
{
    GC_ENTER();
    char *ptr, *string;
    int character, junk, sign, overflow;
    long i, start, end, radix, length, integer, check;
    LispObj *result;

    LispObj *ostring, *ostart, *oend, *oradix, *junk_allowed;

    junk_allowed = ARGUMENT(4);
    oradix = ARGUMENT(3);
    oend = ARGUMENT(2);
    ostart = ARGUMENT(1);
    ostring = ARGUMENT(0);

    start = end = radix = 0;
    result = NIL;

    CHECK_STRING(ostring);
    LispCheckSequenceStartEnd(builtin, ostring, ostart, oend,
			      &start, &end, &length);
    string = THESTR(ostring);
    if (oradix == UNSPEC)
	radix = 10;
    else {
	CHECK_INDEX(oradix);
	radix = FIXNUM_VALUE(oradix);
    }
    if (radix < 2 || radix > 36)
	LispDestroy("%s: :RADIX %ld must be in the range 2 to 36",
		    STRFUN(builtin), radix);

    integer = check = 0;
    ptr = string + start;
    sign = overflow = 0;

    /* Skip leading white spaces */
    for (i = start; i < end && *ptr && isspace(*ptr); ptr++, i++)
	;

    /* Check for sign specification */
    if (i < end && (*ptr == '-' || *ptr == '+')) {
	sign = *ptr == '-';
	++ptr;
	++i;
    }

    for (junk = 0; i < end; i++, ptr++) {
	character = *ptr;
	if (islower(character))
	    character = toupper(character);
	if (character >= '0' && character <= '9') {
	    if (character - '0' >= radix)
		junk = 1;
	    else {
		check = integer;
		integer = integer * radix + character - '0';
	    }
	}
	else if (character >= 'A' && character <= 'Z') {
	    if (character - 'A' + 10 >= radix)
		junk = 1;
	    else {
		check = integer;
		integer = integer * radix + character - 'A' + 10;
	    }
	}
	else {
	    if (isspace(character))
		break;
	    junk = 1;
	}

	if (junk)
	    break;

	if (!overflow && check > integer)
	    overflow = 1;
	/* keep looping just to count read bytes */
    }

    if (!junk)
	/* Skip white spaces */
	for (; i < end && *ptr && isspace(*ptr); ptr++, i++)
	    ;

    if ((junk || ptr == string) &&
	(junk_allowed == UNSPEC || junk_allowed == NIL))
	LispDestroy("%s: %s has a bad integer representation",
		    STRFUN(builtin), STROBJ(ostring));
    else if (ptr == string)
	result = NIL;
    else if (overflow) {
	mpi *bigi = LispMalloc(sizeof(mpi));
	char *str;

	length = end - start + sign;
	str = LispMalloc(length + 1);

	strncpy(str, string - sign, length + sign);
	str[length + sign] = '\0';
	mpi_init(bigi);
	mpi_setstr(bigi, str, radix);
	LispFree(str);
	result = BIGNUM(bigi);
    }
    else
	result = INTEGER(sign ? -integer : integer);

    GC_PROTECT(result);
    RETURN(0) = FIXNUM(i);
    RETURN_COUNT = 1;
    GC_LEAVE();

    return (result);
}
Пример #20
0
Файл: require.c Проект: 8l/xedit
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);
}
Пример #21
0
Файл: string.c Проект: 8l/xedit
static LispObj *
LispStringTrim(LispBuiltin *builtin, int left, int right, int inplace)
/*
 string-{,left-,right-}trim character-bag string
*/
{
    unsigned char *string;
    long start, end, length;

    LispObj *ochars, *ostring;

    ostring = ARGUMENT(1);
    ochars = ARGUMENT(0);

    if (!POINTERP(ochars) || !(XSTRINGP(ochars) || XCONSP(ochars))) {
	if (ARRAYP(ochars) && ochars->data.array.rank == 1)
	    ochars = ochars->data.array.list;
	else
	    LispDestroy("%s: %s is not a sequence",
			STRFUN(builtin), STROBJ(ochars));
    }
    CHECK_STRING(ostring);

    string = (unsigned char*)THESTR(ostring);
    length = STRLEN(ostring);

    start = 0;
    end = length;

    if (XSTRINGP(ochars)) {
	unsigned char *chars = (unsigned char*)THESTR(ochars);
	long i, clength = STRLEN(ochars);

	if (left) {
	    for (; start < end; start++) {
		for (i = 0; i < clength; i++)
		    if (string[start] == chars[i])
			break;
		if (i >= clength)
		    break;
	    }
	}
	if (right) {
	    for (--end; end >= 0; end--) {
		for (i = 0; i < clength; i++)
		    if (string[end] == chars[i])
			break;
		if (i >= clength)
		    break;
	    }
	    ++end;
	}
    }
    else {
	LispObj *ochar, *list;

	if (left) {
	    for (; start < end; start++) {
		for (list = ochars; CONSP(list); list = CDR(list)) {
		    ochar = CAR(list);
		    if (SCHARP(ochar) && string[start] == SCHAR_VALUE(ochar))
			break;
		}
		if (!CONSP(list))
		    break;
	    }
	}
	if (right) {
	    for (--end; end >= 0; end--) {
		for (list = ochars; CONSP(list); list = CDR(list)) {
		    ochar = CAR(list);
		    if (SCHARP(ochar) && string[end] == SCHAR_VALUE(ochar))
			break;
		}
		if (!CONSP(list))
		    break;
	    }
	    ++end;
	}
    }

    if (start == 0 && end == length)
	return (ostring);

    length = end - start;

    if (inplace) {
	CHECK_STRING_WRITABLE(ostring);
	memmove(string, string + start, length);
	string[length] = '\0';
	STRLEN(ostring) = length;
    }
    else {
	string = LispMalloc(length + 1);
	memcpy(string, THESTR(ostring) + start, length);
	string[length] = '\0';
	ostring = LSTRING2((char*)string, length);
    }

    return (ostring);
}
Пример #22
0
/* 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);
}
Пример #23
0
Файл: string.c Проект: 8l/xedit
LispObj *
LispStringCapitalize(LispBuiltin *builtin, int inplace)
/*
 string-capitalize string &key start end
 nstring-capitalize string &key start end
 */
{
    LispObj *result;
    char *string, *newstring;
    long start, end, length, offset, upcase;

    LispObj *ostring, *ostart, *oend;

    oend = ARGUMENT(2);
    ostart = ARGUMENT(1);
    ostring = ARGUMENT(0);
    CHECK_STRING(ostring);
    LispCheckSequenceStartEnd(builtin, ostring, ostart, oend,
			      &start, &end, &offset);
    result = ostring;
    string = THESTR(ostring);
    length = STRLEN(ostring);

    /* first check if something need to be done */
    for (upcase = 1, offset = start; offset < end; offset++) {
	if (upcase) {
	    if (!isalnum(string[offset]))
		continue;
	    if (string[offset] != toupper(string[offset]))
		break;
	    upcase = 0;
	}
	else {
	    if (isalnum(string[offset])) {
		if (string[offset] != tolower(string[offset]))
		    break;
	    }
	    else
		upcase = 1;
	}
    }

    if (offset >= end)
	return (result);

    if (inplace) {
	CHECK_STRING_WRITABLE(ostring);
	newstring = string;
    }
    else {
	/* capitalize a copy of argument */
	newstring = LispMalloc(length + 1);
	memcpy(newstring, string, length);
	newstring[length] = '\0';
    }
    for (; offset < end; offset++) {
	if (upcase) {
	    if (!isalnum(string[offset]))
		continue;
	    newstring[offset] = toupper(string[offset]);
	    upcase = 0;
	}
	else {
	    if (isalnum(newstring[offset]))
		newstring[offset] = tolower(string[offset]);
	    else
		upcase = 1;
	}
    }

    if (!inplace)
	result = LSTRING2(newstring, length);

    return (result);
}
Пример #24
0
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);
}
Пример #25
0
Файл: regex.c Проект: 8l/xedit
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);
}