/* XXX ignoring element-type */
LispObj *
Lisp_MakeString(LispBuiltin *builtin)
/*
make-string size &key initial-element element-type
*/
{
long length;
char *string, initial;
LispObj *size, *initial_element;
initial_element = ARGUMENT(1);
size = ARGUMENT(0);
CHECK_INDEX(size);
length = FIXNUM_VALUE(size);
if (initial_element != UNSPEC) {
CHECK_SCHAR(initial_element);
initial = SCHAR_VALUE(initial_element);
}
else
initial = 0;
string = LispMalloc(length + 1);
memset(string, initial, length);
string[length] = '\0';
return (LSTRING2(string, length));
}
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);
}
/*
* Implementation
*/
static re_cod *
LispRecomp(LispBuiltin *builtin, char *pattern, int cflags)
{
int code;
re_cod *regex = LispMalloc(sizeof(re_cod));
if ((code = recomp(regex, pattern, cflags)) != 0) {
char buffer[256];
reerror(code, regex, buffer, sizeof(buffer));
refree(regex);
LispFree(regex);
LispDestroy("%s: recomp(\"%s\"): %s", STRFUN(builtin), pattern, buffer);
}
return (regex);
}
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_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);
}
/* 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);
}
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);
}
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);
}
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);
}
