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);
}
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);
}
/* 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);
}
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_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);
}
