384 lines
9.1 KiB
C
384 lines
9.1 KiB
C
/*
|
|
*
|
|
* s t r . c -- Strings management
|
|
*
|
|
* Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
*
|
|
*
|
|
* Permission to use, copy, modify, distribute,and license this
|
|
* software and its documentation for any purpose is hereby granted,
|
|
* provided that existing copyright notices are retained in all
|
|
* copies and that this notice is included verbatim in any
|
|
* distributions. No written agreement, license, or royalty fee is
|
|
* required for any of the authorized uses.
|
|
* This software is provided ``AS IS'' without express or implied
|
|
* warranty.
|
|
*
|
|
* Author: Erick Gallesio [eg@kaolin.unice.fr]
|
|
* Creation date: ??????
|
|
* Last file update: 3-Sep-1999 20:59 (eg)
|
|
*/
|
|
|
|
#include <ctype.h>
|
|
#include "stk.h"
|
|
|
|
static char bad_string_message[] = "comparing string: bad string";
|
|
|
|
static int stringcomp(SCM s1, SCM s2)
|
|
{
|
|
register int l1, l2;
|
|
register char *str1, *str2;
|
|
|
|
if (NSTRINGP(s1)) Err(bad_string_message, s1);
|
|
if (NSTRINGP(s2)) Err(bad_string_message, s2);
|
|
|
|
for (l1=STRSIZE(s1), str1=CHARS(s1), l2=STRSIZE(s2), str2=CHARS(s2);
|
|
l1 && l2;
|
|
l1--, str1++, l2--, str2++)
|
|
if (*str1 != *str2) return ((unsigned char) *str1 - (unsigned char) *str2);
|
|
|
|
/* l1 == 0 || l2 == 0 */
|
|
return l1 ? +1 : (l2 ? -1 : 0);
|
|
}
|
|
|
|
|
|
static int stringcompi(SCM s1, SCM s2)
|
|
{
|
|
register int l1, l2;
|
|
register char *str1, *str2;
|
|
|
|
if (NSTRINGP(s1)) Err(bad_string_message, s1);
|
|
if (NSTRINGP(s2)) Err(bad_string_message, s2);
|
|
|
|
for (l1=STRSIZE(s1), str1=CHARS(s1), l2=STRSIZE(s2), str2=CHARS(s2);
|
|
l1 && l2;
|
|
l1--, str1++, l2--, str2++)
|
|
if (tolower(*str1) != tolower(*str2))
|
|
return (tolower(*str1) - tolower(*str2));
|
|
|
|
/* l1 == 0 || l2 == 0 */
|
|
return l1 ? +1 : (l2 ? -1 : 0);
|
|
}
|
|
|
|
SCM STk_makestrg(int len, char *init)
|
|
{
|
|
register SCM z;
|
|
|
|
NEWCELL(z, tc_string);
|
|
z->storage_as.string.dim = len;
|
|
z->storage_as.string.data = (char *) must_malloc((unsigned int) len+1);
|
|
z->storage_as.string.data[len] = 0;
|
|
|
|
if (init) memcpy(z->storage_as.string.data, init, (unsigned int) len);
|
|
return z;
|
|
}
|
|
|
|
SCM STk_embed_C_string(char *str)
|
|
{
|
|
/* Embed a C string in Scheme world (the dting must be dynamic */
|
|
register SCM z;
|
|
|
|
NEWCELL(z, tc_string);
|
|
z->storage_as.string.dim = strlen(str);
|
|
z->storage_as.string.data = str;
|
|
|
|
return z;
|
|
}
|
|
|
|
|
|
/**** Section 6.7 ****/
|
|
|
|
PRIMITIVE STk_stringp(SCM obj)
|
|
{
|
|
return STRINGP(obj) ? Truth: Ntruth;
|
|
}
|
|
|
|
PRIMITIVE STk_make_string(SCM len, SCM init_char)
|
|
{
|
|
long k;
|
|
SCM z;
|
|
|
|
ENTER_PRIMITIVE("make-string");
|
|
if ((k=STk_integer_value(len)) < 0) Serror("bad string length", len);
|
|
|
|
z = STk_makestrg(k, NULL);
|
|
|
|
if (init_char != UNBOUND) {
|
|
if (CHARP(init_char)) {
|
|
char c = CHAR(init_char);
|
|
int j;
|
|
|
|
for(j=0 ;j<k; j++) z->storage_as.string.data[j] = c;
|
|
}
|
|
else
|
|
Serror("initializing char not valid", init_char); }
|
|
return z;
|
|
}
|
|
|
|
PRIMITIVE STk_lstring(SCM l, int len)
|
|
{
|
|
int j;
|
|
SCM tmp, z;
|
|
|
|
if (len < 0) Err("string: bad list", l);
|
|
z = STk_makestrg(len, NULL);
|
|
|
|
/* copy element in newly allocated string */
|
|
for (j=0; j < len; j++, l=CDR(l)) {
|
|
tmp = CAR(l);
|
|
if (NCHARP(tmp)) Err("string: bad element", tmp);
|
|
CHARS(z)[j] = CHAR(tmp);
|
|
}
|
|
return z;
|
|
}
|
|
|
|
PRIMITIVE STk_string_length(SCM str)
|
|
{
|
|
if (NSTRINGP(str)) Err("string-length: not a string", str);
|
|
return STk_makeinteger(STRSIZE(str));
|
|
}
|
|
|
|
PRIMITIVE STk_string_ref(SCM str, SCM index)
|
|
{
|
|
long k;
|
|
|
|
if (NSTRINGP(str)) Err("string-ref: not a string", str);
|
|
if ((k=STk_integer_value(index)) < 0) Err("string-ref: bad index", index);
|
|
|
|
if (k >= STRSIZE(str))
|
|
Err("string-ref: index out of bounds", index);
|
|
return STk_makechar((unsigned char) CHARS(str)[k]);
|
|
}
|
|
|
|
PRIMITIVE STk_string_set(SCM str, SCM index, SCM value)
|
|
{
|
|
long k;
|
|
|
|
if (NSTRINGP(str)) Err("string-set!: not a string", str);
|
|
if ((k=STk_integer_value(index)) < 0) Err("string-set!: bad index", index);
|
|
|
|
if (k >= STRSIZE(str))
|
|
Err("string-set!: index out of bounds", index);
|
|
|
|
if (NCHARP(value)) Err("string-set!: value is not a char", value);
|
|
|
|
CHARS(str)[k] = CHAR(value);
|
|
return UNDEFINED;
|
|
}
|
|
|
|
PRIMITIVE STk_streq (SCM s1,SCM s2){return (stringcomp(s1,s2)==0)? Truth: Ntruth;}
|
|
PRIMITIVE STk_strless (SCM s1,SCM s2){return (stringcomp(s1,s2)<0) ? Truth: Ntruth;}
|
|
PRIMITIVE STk_strgt (SCM s1,SCM s2){return (stringcomp(s1,s2)>0) ? Truth: Ntruth;}
|
|
PRIMITIVE STk_strlesse(SCM s1,SCM s2){return (stringcomp(s1,s2)<=0)? Truth: Ntruth;}
|
|
PRIMITIVE STk_strgte (SCM s1,SCM s2){return (stringcomp(s1,s2)>=0)? Truth: Ntruth;}
|
|
|
|
PRIMITIVE STk_streqi (SCM s1,SCM s2){return (stringcompi(s1,s2)==0)?Truth:Ntruth;}
|
|
PRIMITIVE STk_strlessi (SCM s1,SCM s2){return (stringcompi(s1,s2)<0) ?Truth:Ntruth;}
|
|
PRIMITIVE STk_strgti (SCM s1,SCM s2){return (stringcompi(s1,s2)>0) ?Truth:Ntruth;}
|
|
PRIMITIVE STk_strlessei(SCM s1,SCM s2){return (stringcompi(s1,s2)<=0)?Truth:Ntruth;}
|
|
PRIMITIVE STk_strgtei (SCM s1,SCM s2){return (stringcompi(s1,s2)>=0)?Truth:Ntruth;}
|
|
|
|
PRIMITIVE STk_substring(SCM string, SCM start, SCM end)
|
|
{
|
|
char msg[] = "substring: not an integer";
|
|
int from, to;
|
|
|
|
if (NSTRINGP(string)) Err("substring: not a string", string);
|
|
|
|
if ((from=STk_integer_value(start))==LONG_MIN) Err(msg ,start);
|
|
if ((to=STk_integer_value(end)) == LONG_MIN) Err(msg ,end);
|
|
|
|
if (0 <= from && from <= to && to <= STRSIZE(string))
|
|
return STk_makestrg(to - from, CHARS(string)+from);
|
|
|
|
Err("substring: bad bounds", Cons(start, end));
|
|
return UNDEFINED; /* cannot occur */
|
|
}
|
|
|
|
PRIMITIVE STk_string_append(SCM l, int len)
|
|
{
|
|
int i, total=0;
|
|
SCM z, tmp = l;
|
|
char *p;
|
|
|
|
/* Compute total length of resulting string */
|
|
for (i = 0; i < len; i++) {
|
|
if (NSTRINGP(CAR(tmp)))
|
|
Err("string-append: bad string", CAR(tmp));
|
|
total += STRSIZE(CAR(tmp));
|
|
tmp = CDR(tmp);
|
|
}
|
|
|
|
/* Allocate result */
|
|
z = STk_makestrg(total, NULL);
|
|
p = CHARS(z);
|
|
|
|
/* copy strings */
|
|
for (i=0; i < len; i++) {
|
|
memcpy(p, CHARS(CAR(l)), (unsigned int) STRSIZE(CAR(l)));
|
|
p += STRSIZE(CAR(l));
|
|
l = CDR(l);
|
|
}
|
|
return z;
|
|
}
|
|
|
|
PRIMITIVE STk_string2list(SCM str)
|
|
{
|
|
int j, len;
|
|
SCM tmp, z = NIL;
|
|
|
|
if (NSTRINGP(str)) Err("string->list: not a string", str);
|
|
len = STRSIZE(str);
|
|
|
|
for (j=0; j<len; j++) {
|
|
if (j == 0)
|
|
tmp = z = Cons(STk_makechar(CHARS(str)[j]), NIL);
|
|
else
|
|
tmp = CDR(tmp) = Cons(STk_makechar(CHARS(str)[j]), NIL);
|
|
}
|
|
return z;
|
|
}
|
|
|
|
PRIMITIVE STk_list2string(SCM l)
|
|
{
|
|
int j=0, len = STk_llength(l);
|
|
SCM z;
|
|
|
|
ENTER_PRIMITIVE("list->string");
|
|
if (len < 0) Serror("bad list", l);
|
|
z = STk_makestrg(len, NULL);
|
|
|
|
for ( ; NNULLP(l); l=CDR(l)) {
|
|
if (NCHARP(CAR(l))) Serror("not a character", CAR(l));
|
|
CHARS(z)[j++] = CHAR(CAR(l));
|
|
}
|
|
return z;
|
|
}
|
|
|
|
PRIMITIVE STk_string_copy(SCM str)
|
|
{
|
|
if (NSTRINGP(str)) Err("string-copy: not a string", str);
|
|
return STk_makestring(CHARS(str));
|
|
}
|
|
|
|
PRIMITIVE STk_string_fill(SCM str, SCM c)
|
|
{
|
|
int len, i;
|
|
char c_char;
|
|
|
|
ENTER_PRIMITIVE("string-fill");
|
|
if (NSTRINGP(str)) Serror("not a string", str);
|
|
if (NCHARP(c)) Serror("not a char", c);
|
|
|
|
len = STRSIZE(str);
|
|
c_char = CHAR(c);
|
|
|
|
for (i = 0; i < len; i++)
|
|
CHARS(str)[i] = c_char;
|
|
return UNDEFINED;
|
|
}
|
|
|
|
|
|
/*
|
|
*
|
|
* STk bonus
|
|
*
|
|
*/
|
|
|
|
static char *Memmem(char *s1, int l1, char *s2, int l2)
|
|
{
|
|
if (l2 == 0) return s1;
|
|
|
|
for ( ; l1 >= l2 ; s1++, l1--)
|
|
if (memcmp(s1, s2, (unsigned int) l2) == 0) return s1;
|
|
|
|
return NULL;
|
|
}
|
|
|
|
PRIMITIVE STk_string_findp(SCM s1, SCM s2)
|
|
{
|
|
char msg[] = "string-find?: bad string";
|
|
|
|
if (NSTRINGP(s1)) Err(msg,s1);
|
|
if (NSTRINGP(s2)) Err(msg,s2);
|
|
|
|
return Memmem(CHARS(s2), STRSIZE(s2), CHARS(s1), STRSIZE(s1)) ? Truth: Ntruth;
|
|
}
|
|
|
|
PRIMITIVE STk_string_index(SCM s1, SCM s2)
|
|
{
|
|
char *p, msg[] = "string-index: bad string";
|
|
|
|
if (NSTRINGP(s1)) Err(msg,s1);
|
|
if (NSTRINGP(s2)) Err(msg,s2);
|
|
|
|
p = Memmem(CHARS(s2), STRSIZE(s2), CHARS(s1), STRSIZE(s1));
|
|
|
|
return p? STk_makeinteger(p - CHARS(s2)) : Ntruth;
|
|
}
|
|
|
|
|
|
|
|
PRIMITIVE STk_string_lower(SCM s)
|
|
{
|
|
SCM z;
|
|
register char *p, *q;
|
|
|
|
if (NSTRINGP(s)) Err("string-lower: not a string", s);
|
|
z = STk_makestrg((int) strlen(CHARS(s)), NULL);
|
|
|
|
for (p=CHARS(s), q=CHARS(z); *p; p++, q++) *q = tolower(*p);
|
|
return z;
|
|
}
|
|
|
|
PRIMITIVE STk_string_upper(SCM s)
|
|
{
|
|
SCM z;
|
|
register char *p, *q;
|
|
|
|
if (NSTRINGP(s)) Err("string-upper: not a string", s);
|
|
z = STk_makestrg((int) strlen(CHARS(s)), NULL);
|
|
|
|
for (p=CHARS(s), q=CHARS(z); *p; p++, q++) *q = toupper(*p);
|
|
return z;
|
|
}
|
|
|
|
PRIMITIVE STk_split_string(SCM string, SCM delimiters)
|
|
{
|
|
SCM result = NIL;
|
|
char *c_string, *c_delimiters, *s;
|
|
|
|
ENTER_PRIMITIVE("split-string");
|
|
if (!STRINGP(string)) Serror("bad string", string);
|
|
c_string = CHARS(string);
|
|
|
|
if (delimiters == UNBOUND)
|
|
c_delimiters = " \t\n";
|
|
else {
|
|
if (!STRINGP(delimiters))
|
|
Serror("bad delimiter string", delimiters);
|
|
c_delimiters = CHARS(delimiters);
|
|
}
|
|
|
|
for (s = c_string; *s; s++) {
|
|
if (strchr(c_delimiters, *s)) {
|
|
if (s > c_string) {
|
|
int len;
|
|
SCM tmp;
|
|
|
|
len = s - c_string;
|
|
tmp = STk_makestrg(len, NULL);
|
|
|
|
strncpy(CHARS(tmp), c_string, (unsigned int) len);
|
|
CHARS(tmp)[len] = '\0';
|
|
result = Cons(tmp, result);
|
|
}
|
|
c_string = s + 1;
|
|
}
|
|
}
|
|
if (s > c_string)
|
|
result = Cons(STk_makestring(c_string), result);
|
|
|
|
return STk_reverse(result);
|
|
}
|