/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/**************\
*              *
*  KlO  String *
*  BODY        *
*              *
\**************/

#include "EXTERN.h"
#include <ctype.h>
#include "klone.h"
#include "kl_number.h"
#include "kl_atom.h"
#include "kl_list.h"
#include "klgeneric.h"
#include "INTERN.h"
#include "kl_string.h"

char *KlReComp();
char *KlUnstripString(), *KlStripString();
static char *strings_temp_buffer;
static int strings_temp_buffer_size = 0;
static char *control_caret = "\x1e";
static char *quote_string = "\"";
static int KlUnstripStringLength;	/* set by KlUnstripString */

extern KlO KlStringHash();
DECLARE_strchr;


/*
 * Constructor:
 * KlStringMake
 * argument 1: the string, which will be COPIED.
 */

KlString
KlStringMake(s)
    char *s;				/* the string itself */
{
    KlString object;

    object = (KlString) KlOMake(KlStringType);
    if (s) {
	object->size = strlen(s);
	object->string = (char *) Malloc((size_t) object->size + 1);
	strcpy(object->string, s);
    } else {
	KlModStringSetLength(object, 0);
	object->string = (char *) Malloc((size_t) 1);
	object->string[0] = '\0';
    }
    return object;
}

/*
 * Constructor:
 * KlStringMakeFromBytes
 * argument 1: the length of the string
 * argument 2: the string, which will be COPIED.
 */

KlString
KlStringMakeFromBytes(l, s)
    int l;
    char *s;				/* the string itself */
{
    KlString object;

    object = (KlString) KlOMake(KlStringType);
    object->string = (char *) Malloc((size_t) l+1);
    bcopy(s, object->string, l);
    object->string[l] = '\0';
    KlModStringSetLength(object, l);
    return object;
}

/*
 * Constructor:
 * KlStringMakeNoCopy
 * argument 1: the length of the string
 * argument 2: the string, which will NOT be copied, and be freed by Klone GC
 */

KlString
KlStringMakeNoCopy(l, s)
    int l;
    char *s;				/* the string itself */
{
    KlString object;

    object = (KlString) KlOMake(KlStringType);
    object->string = s;
    object->size = l;
    return object;
}

/* KlStringNMake
 * allocates a string with room for n chars (allocates one more for the
 * terminating null byte)
 * WARNING: do not forget to put a \0 yourself at the end after filling it!
 */

KlString
KlStringNMake(n)
    int n;
{
    KlString object = (KlString) KlOMake(KlStringType);

    KlModStringSetLength(object, n);
    object->string = (char *) Malloc((size_t) n + 1);
    return object;
}

/* KlStringNMakeKl
 * create a string from Klone, very useful
 * (make-string number-of-chars [char])
 * returns a string made of number-of-chars chars (defaults to space)
 * (make-string 5 #\x)  ==>  "xxxxx"
 */

KlO
KlStringNMakeKl(argc, argv)
    int argc;
    KlNumber *argv;
{
    int size;
    KlString obj;
    int fill_char = ' ';

    if (argc == 2) {
	KlMustBeNumber(argv[1], 1);
	fill_char = argv[1]->number;
    } else if (argc != 1) {
	return KlBadNumberOfArguments((char *) argc);
    }
    KlMustBeNumber(argv[0], 0);
    if ((size = argv[0]->number) > 0) {
	obj = KlStringNMake(size);
	KlMemSet(obj->string, fill_char, size);
	obj->string[size] = '\0';
    } else {
	obj = KlStringMake(0);
    }
    return (KlO) obj;	
}

 
/* KlCStringPrint is like KlStringPrint, but for C strings
 * obeys KlPrintReadably et al...
 */

KlCStringPrint(len, string, stream)
    int len;
    char *string;
    KlO stream;
{
    if (KlPrintReadably) {
	if (KlPrintAsRawStrings 
	    && KlStringIsRawPrintable(len, string)) {
	    KlSPutBytes(1, control_caret, stream);
	    KlSPutBytes(len, string, stream);
	    KlSPutBytes(1, control_caret, stream);
	} else {
	    KlSPutBytes(1, quote_string, stream);
	    KlSPuts(KlUnstripString(len, string), stream);
	    KlSPutBytes(1, quote_string, stream);
	}
    } else {
	if (KlPrintBinary) {
	    KlSPrintf(stream, "\001 \002%d\002", len);
	}
	KlSPutBytes(len, string, stream);
    } 
}

/*
 * KlStringPrint:
 * We print strings surrounded by double quotes.
 */

KlO
KlStringPrint(obj, stream)
    KlString obj;
    KlO stream;
{
    KlCStringPrint(obj->size, obj->string, stream);
    return (KlO) obj;
}

int 
KlStringIsRawPrintable(size, string)
    int size;
    char *string;
{
    char *end = string + size;
    while (string < end)
	if (*string++ == 30)
	    return 0;
    return 1;
}

/* KlStringFree
 */

KlO
KlStringFree(obj)
    KlString obj;
{
    Free(obj->string);
    Free(obj);
    return (KlO) obj;
}


/* KlStringCopy
 */

KlO
KlStringCopy(obj)
    KlString obj;
{
    return (KlO) KlStringMakeFromBytes(KlModStringLength(obj), obj->string);
}

/*
 * KlStringEqual
 * tests 2 strings for equality (returns it if true)
 */

KlO
KlStringEqual(s1, s2)
    KlString s1, s2;
{
    if (!KlIsAString(s2)
	|| s1->size != KlStringLength(s2)
	|| KlIsASymbol(s2)
	|| bcmp(s1->string, s2->string, s1->size))
	    return NIL;
	else
	    return (KlO) s1;
}

KlO
KlStringLengthKl(s)
    KlString s;
{
    return (KlO) KlNumberMake(KlModStringLength(s));
}

/*********\
*         *
* methods *
*         *
\*********/

/* KlStringAdd
 * concatenates strings
 * tolerates nils (ignored) and numbers whose printed representations are used.
 */

KlO
KlStringAdd(argc, argv)
    int argc;
    KlString argv[];
{
    int required_length = KlStringLength(argv[0]), i;
    char *p;

    /* check args & needed length */
    for (i = 1; i < argc; i++) {
	if (KlIsAString(argv[i]))
	    required_length += KlStringLength(argv[i]);
	else if (KlFalseP(argv[i]))
	    ;
	else if (KlIsANumber(argv[i]))
	    required_length += 
		KlStringLength(KlStringCoerce(KlStringType, argv[i]));
	else
	    KlBadArgument(argv[i], i, KlTraitName(KlTrait_string));
    }

    /* verify we have room in temp space */
    if (required_length >= strings_temp_buffer_size) {
	if (!strings_temp_buffer) {
	    strings_temp_buffer = (char *)
		Malloc(strings_temp_buffer_size = Max(required_length + 1, 256));
	} else {
	    strings_temp_buffer_size = required_length + 1;
	    strings_temp_buffer = (char *)
		Realloc(strings_temp_buffer, strings_temp_buffer_size);
	}
    }
    /* do the concatenation */
    strings_temp_buffer[0] = '\0';
    for (i = 0, p = strings_temp_buffer; i < argc; i++) {
	int l;
	KlString kls = argv[i];
	if (KlIsAString(kls))
	    ;
	else if (KlIsANumber(kls))
	    kls = (KlString) KlStringCoerce(KlStringType, argv[i]);
	else
	    kls = KlNilString;

	bcopy(kls->string, p, l = KlStringLength(kls));
 	p += l;
    }
    return (KlO) KlStringMakeFromBytes(required_length, strings_temp_buffer);
}

/* KlStringStrcat
 * concatenates a C string at the end of a Klone one
 * WARNING: Cstring must not contain null bytes (it is a C string...)
 */

KlString
KlStringStrcat(string, Cstring)
    KlString string;
    char *Cstring;
{
    int required_length = KlModStringLength(string) + strlen(Cstring);

    if (KlHasTrait(string, KlTrait_unreallocable)) {
	return (KlString) KlError(KlE_NO_APPEND, string);
    }
    string->string = (char *) Realloc(string->string, required_length + 1);
    /* do the concatenation */
    strcat(string->string, Cstring);
    KlModStringSetLength(string, required_length);
    return string;
}

/* KlStringGet
 * get a char at an index
 */

KlO
KlStringGet(obj, key, def)
    KlUString obj;
    KlNumber key;
    KlO def;
{
    int i, l;

    if (KlIsANumber(key)) {		/* array */
	i = key->number;
	l = KlStringLength(obj);
	if (i < l) {
	    if (i < 0) {
		if (l) {
		    i = l - 1;
		} else {
		    return KlExecuteGetDefault(obj, key, def);
		}
	    }
	    return (KlO) KlNumberMake(obj->string[i]);
	} else {
	    return KlExecuteGetDefault(obj, key, def);
	}
    } else {
	KlMustBeNumber(key, 1);		/* expansion? */
	return KlExecuteGetDefault(obj, key, def);
    }
}

/* KlStringPut
 * puts a char at an index
 */

KlO
KlStringPut(obj, key, val)
    KlUString obj;
    KlNumber key;
    KlNumber val;
{
    int i, l;

    if (KlIsANumber(key)) {		/* array */
	i = key->number;
	l = KlModStringLength(obj);
	if (i < 0) {			/* <0 means append to end */
	    i = l;
	}
	if (KlIsANumber(val)) {
	    if (i < l) {
		obj->string[i] = val->number;
		return (KlO) obj;
	    } else {
		if (KlHasTrait(obj, KlTrait_unreallocable)) {
		    return KlError(KlE_NO_APPEND, obj);
		}
		obj->string = (unsigned char *) Realloc(obj->string, i + 2);
		KlModStringSetLength(obj, i+1);
		KlMemSet(obj->string + l, ' ', i - l);
		obj->string[i] = val->number;
		obj->string[i + 1] = '\0';
	    }
	} else {
	    int inserted_len;
	    KlMustBeString(val, 2);
	    inserted_len = KlStringLength(val);
	    if ((i + inserted_len) > l) {
		if (KlHasTrait(obj, KlTrait_unreallocable)) {
		    return KlError(KlE_NO_APPEND, obj);
		}
		obj->string = (unsigned char *) Realloc(obj->string,
							i + inserted_len + 1);
		obj->string[i + inserted_len] = '\0';
		KlModStringSetLength(obj, i + inserted_len);
		if (i > l) 		/* fill with blanks */
		    KlMemSet(obj->string + l, ' ', i - l);
	    }
	    bcopy(((KlString)val)->string, obj->string + i, inserted_len);
	}
    } else {
	KlMustBeNumber(key, 1);
    }
    return (KlO) obj;
}

/* KlStringInsert
 * puts a char at an index
 */

KlO
KlStringInsert(obj, key, val)
    KlUString obj;
    KlNumber key;
    KlNumber val;
{
    int i, l;
    unsigned char *p, *q, *start;
    int inserted_len;

    if (KlHasTrait(obj, KlTrait_unreallocable)) {
	return KlError(KlE_NO_APPEND, obj);
    }
    
    KlMustBeNumber(key, 1);
    if (KlIsANumber(val)) {
	inserted_len = 1;
    } else {
	KlMustBeString(val, 2);
	inserted_len = KlStringLength(val);
    }
    i = key->number;
    l = KlModStringLength(obj);
    if (i < 0 || i >= l) {		/* after end = Put */
	return KlStringPut(obj, key, val);
    }
    obj->string = (unsigned char *) Realloc(obj->string, l + inserted_len + 1);
    KlModStringSetLength(obj, l + inserted_len);
    start = obj->string + i;
    p = obj->string + l;
    q = p + inserted_len;

    while (p >= start) {
	*q-- = *p--;
    }
    if (KlIsANumber(val)) {
	obj->string[i] = val->number;
    } else {
	bcopy(((KlString) val)->string, obj->string + i, inserted_len);
    }    

    return (KlO) obj;
}

/* KlStringDelete
 * deletes char at an index
 */

KlO
KlStringDelete(obj, key)
    KlUString obj;
    KlNumber key;
{
    int i, l;
    unsigned char *p, *end;

    if (!obj->string) {
	return (KlO) obj;
    }
    if (KlIsANumber(key)) {		/* array */
	i = key->number;
	l = KlModStringLength(obj);
	if (i < 0) {
	    i = (l ? l - 1 : 0);
	} 
	p = obj->string + i;
	end = obj->string + l;
	while (p < end) {
	    *p = *(p+1);
	    p++;
	}
	if (l && i < l && !KlIsASymbol(obj))
	    obj->size--;
    } else {
	KlMustBeNumber(key, 1);
    }
    return (KlO) obj;
}

/* KlStringCoerce
 * number ==> does a printf into a string
 */

/*ARGSUSED*/
KlO
KlStringCoerce(totype, obj)
    KlType totype;
    KlO obj;
{
    char tmp_str[20];

    if (KlIsASymbol(obj)) {
	return (KlO) KlStringMake(((KlString) obj)->string);
    } else if (KlIsANumber(obj)) {
	if (KlIsAReal(obj)) {
	    sprintf(tmp_str, "%g", ((KlReal) obj)->real);
	    if (!strchr(tmp_str, '.') && !strchr(tmp_str, 'e')) {
		strcat(tmp_str, ".0");	/* adds a dot to show it is a real */
	    }
	} else {
	    sprintf(tmp_str, "%d", ((KlNumber) obj)->number);
	}
	return (KlO) KlStringMake(tmp_str);
    } else if (KlIsAList(obj)) {
	int l = ((KlList) obj)->size;
	KlO *q = ((KlList) obj)->list, *last = q + l;
	KlString s = (KlString) KlStringNMake(l);
	char *p = s->string;
	int i;

	while (q < last) {
	    KlMustBeNumber(*q, q - ((KlList) obj)->list);
	    *p++ = ((KlNumber) *q++)->number;
	}
	*p = '\0';
	return (KlO) s;
    } else if (KlIsAType(obj)) {
	return (KlO) KlStringMake(KlTypeCName(((KlType)obj)));
    }
    return 0;
}

KlO
KlStringNth(obj, i, value)
    KlUString obj;
    UInt i;
    KlNumber value;
{
    if (i >= KlModStringLength(obj))
	return NIL;
    if (value) {
	obj->string[i] = value->number;
	return (KlO) obj;
    } else {
	return (KlO) KlNumberMake(obj->string[i]);
    }
}

int
KlStringCompare(o1, o2)
    KlString o1, o2;
{
    if (o1 == o2) return 0;/* shortcut */

    KlMustBeString(o2, 1);
    return strcmp(o1->string, o2->string);
}

KlStringDolist(string, var, argc, argv)
    KlString string;
    KlO var;
    int argc;
    KlO *argv;
{
    KlGCMark();
    if (KlIsASymbol(string)) {	/* no null chars embedded,
				   and not modifiable */
	unsigned char *p = (unsigned char *) string->string;
	while (*p) {
	    KlSend_setq(var, KlNumberMake(*p));
	    KlProgn(argc, argv);
	    KlGC();
	    p++;
	}		
    } else {
	int i;
	for (i = 0; i < string->size; i++) {
	    KlSend_setq(var, KlNumberMake(((KlUString) string)->string[i]));
	    KlProgn(argc, argv);
	    KlGC();
	}
    }
}

/**************************************************************************\
* 									   *
* the general  match package						   *
* (match regular-expression string [level])				   *
* returns the sub-string in the levelth enclosing \( and \) or NIL_STRING  *
* or string or NIL if no level given					   *
* 									   *
\**************************************************************************/
/* uses Henry Spencer's REGEXP package
 */

#include "klregexp.h"

/********************************************* private data type definitions */

typedef struct _KlRegexp {
    KlKLONE_HEADER;
    char *string;			/* printable form, string compatible */
    int size;
    regexp *prog;
    KlString matched_string;		/* last regexec-ed string */
}        *KlRegexp;

KlRegexp KlRegcomp();
KlO KlRegexec();
KlString KlRegsub();

KlType KlRegexpType;

#define KlIsARegexp(obj) ((obj)->type == KlRegexpType)
#define KlMustBeRegexp(o, n) KlArgumentMustBe(o, n, KlRegexpType)

/********************************************************************** body */
/* type management 
 */

KlRegexp
KlRegexpMake(expr)
    char *expr;
{
    KlRegexp object;
    regexp *prog = Klregcomp(expr);

    object = (KlRegexp) KlOMake(KlRegexpType);
    object->prog = prog;
    object->size = strlen(expr);
    object->string = (char *) Malloc(object->size + 1);
    object->matched_string = 0;
    strcpy(object->string, expr);
    return (KlRegexp) object;
}

KlRegexpProgFree(prog)
    regexp *prog;
{
    free(prog->startp);		/* lowercase free intentional */
    if (prog->o_parnums) {
	free(prog->o_parnums);
	free(prog->c_parnums);
    }
    free(prog);			/* lowercase free intentional */
}

KlO
KlRegexpFree(obj)
    KlRegexp obj;
{
    Free(obj->string);
    KlDecRef(obj->matched_string);
    KlRegexpProgFree(obj->prog);
    Free(obj);
    return (KlO) obj;
}

/* get: get the offsets of the N-th matched sub-expression
 * (0 is the whole regexp, -1 is the last string matched to)
 */

KlO
KlRegexpGet(obj, key, def)
    KlRegexp obj;
    KlNumber key;
    KlO def;
{
    int offset;

    if (KlIsANumber(key)) {
	offset = key->number;
	if (offset >= 0 && offset < obj->prog->nsubexp && obj->matched_string
	    && (obj->prog->startp[offset] || obj->prog->endp[offset])) {
	    KlList result = KlListNMake(2);
	    KlListStore(result, 0, KlNumberMake(obj->prog->startp[offset]
						- obj->matched_string->string));
	    KlListStore(result, 1, KlNumberMake(obj->prog->endp[offset]
						- obj->matched_string->string));
	    return (KlO) result;
	} else if (offset == -1) {
	    return obj->matched_string ? (KlO) obj->matched_string : NIL;
	} else {
	    return KlExecuteGetDefault(obj, key, def);
	}
    } else if (key == (KlNumber) KlA_depth) {
	return (KlO) KlNumberMake(obj->prog->nsubexp - 1);
    } else {
	KlMustBeNumber(key, 1);
    }
}

/* regcomp
 */

KlRegexp 
KlRegcomp(expr)
    KlString expr;
{
    KlMustBeString(expr, 0);
    return KlRegexpMake(expr->string);
}

/* regexec
 * regexec regexp source [source-offset]
 */

KlO
KlRegexec(argc, argv)
    int argc;
    KlString *argv;
{
    
    int offset;

    switch (argc) {
    case 2:
	offset = 0;
	break;
    case 3:
	KlMustBeNumber(argv[2], 2);
	offset = ((KlNumber)argv[2])->number;
	if (offset < 0) offset = 0;
	break;
    default:
	return KlBadNumberOfArguments(argc);
    }

    KlMustBeRegexp(argv[0], 0);
    KlMustBeString(argv[1], 1);
    KlDecRef(((KlRegexp)argv[0])->matched_string);

    if (offset > KlStringLength(argv[1]))
	offset = KlStringLength(argv[1]);

    return Klregexec(((KlRegexp)argv[0])->prog, argv[1]->string + offset)
	? (KlIncRef(((KlRegexp)argv[0])->matched_string = argv[1]), TRU)
	: (((KlRegexp)argv[0])->matched_string = 0, NIL);
}

/* KlRegsub
 * KlRegsub regexp source [source-offset]
 */

KlString
KlRegsub(argc, argv)
    int argc;
    KlString *argv;
{
    int offset;
    char *dest;
    KlString result;

    switch (argc) {
    case 2:
	offset = 0;
	break;
    case 3:
	KlMustBeNumber(argv[2], 2);
	offset = ((KlNumber)argv[2])->number;
	break;
    default:
	return (KlString) KlBadNumberOfArguments(argc);
    }
    KlMustBeRegexp(argv[0], 0);
    if (KlIsANumber(argv[1])) {		/* just copy bytes */
	int no = ((KlNumber) argv[1])->number;
	KlRegexp obj = (KlRegexp) argv[0];
	if (no >= 0 && no < obj->prog->nsubexp && obj->matched_string
	    && (obj->prog->startp[no] || obj->prog->endp[no])) {
	    return KlStringMakeFromBytes
		(obj->prog->endp[no] - obj->prog->startp[no],
		 obj->prog->startp[no]);
	} else if (no == -1) {		/* whole matched string */
	    return obj->matched_string ? obj->matched_string : KlStringMake(0);
	} else {
	    return (KlString) KlStringMake(0);
	}
    } else {				/* expands bytes in string */
	int size;
	KlMustBeString(argv[1],1 );
	if (offset > KlStringLength(argv[1]))
	    offset = KlStringLength(argv[1]);
	dest = Kl_regsub(((KlRegexp)argv[0])->prog, argv[1]->string + offset,
			 &size);
	return KlStringMakeNoCopy(size, dest); /* no need to copy */
    }
}

/* A shorthand: we can execute regexp, which means regexec or regsub
 * if arg is string or number
 * (regexp string [offset]) ==> (regexec regexp string [offset])
 * (regexp number [offset]) ==> (regsub regexp number [offset])
 */

KlO
KlRegexpExecuteOrApply(obj, list, eval)
    KlRegexp obj;
    KlList list;			/* the call list */
    int eval;				/* must we eval args? */
{
    KlO arg = list->list[1];
    KlNumber kloffset;
    int offset;
    switch (list->size) {
    case 2:		/* no offset */
	offset = 0; 
	break;
    case 3:
	kloffset = (KlNumber) 
	    (eval ? KlSend_eval(list->list[2]) : list->list[2]);
	KlMustBeNumber(kloffset, 2);
	offset = kloffset->number;
	if (offset < 0) offset = 0;
	break;
    default:
	return KlBadNumberOfArguments(list->size);
    }
    if (eval) {
	arg = KlSend_eval(arg);
    }
    if (KlIsANumber(arg)) {		/* code copied from regsub */
	int no = ((KlNumber) arg)->number;
	if (no >= 0 && no < obj->prog->nsubexp && obj->matched_string
	    && (obj->prog->startp[no] || obj->prog->endp[no])) {
	    return (KlO) KlStringMakeFromBytes
		(obj->prog->endp[no] - obj->prog->startp[no],
		 obj->prog->startp[no]);
	} else if (no == -1) {		/* whole matched string */
	    return obj->matched_string ? 
		(KlO) obj->matched_string : (KlO) KlStringMake(0);
	} else {
	    return (KlO) KlStringMake(0);
	}

    } else if (KlIsAString(arg)) {	/* code copied from regexec */
	KlDecRef(obj->matched_string);
	
	if (offset > KlStringLength(arg))
	    offset = KlStringLength(arg);

	return (KlO) Klregexec(obj->prog, ((KlString)arg)->string + offset)
	    ? (KlIncRef(obj->matched_string = (KlString) arg), TRU)
	    : (obj->matched_string = 0, NIL);
	
    } else {				/* unknown arg */
	return KlBadArgument(arg, 0, KlTypeErr_StringOrNumber);
    }
}

KlO
KlRegexpExecute(obj, list)
    KlRegexp obj;
    KlList list;
{
    return KlRegexpExecuteOrApply(obj, list, 1);
}

KlO
KlRegexpApply(obj, list)
    KlRegexp obj;
    KlList list;
{
    return KlRegexpExecuteOrApply(obj, list, 0);
}


/* match
 * implemented with the preceding functions
 */

KlString
KlStringMatchAux(prog, offset)
    regexp *prog;
    int offset;
{
    KlString str;
    int len;

    if (offset >= 0 && offset < prog->nsubexp
	&& (prog->startp[offset] || prog->endp[offset])) {
	len = prog->endp[offset] - prog->startp[offset];
	str = KlStringNMake(len);
	strncpy(str->string, prog->startp[offset], len);
    } else {
	len = 0;
	str = KlStringNMake(0);
    }
    str->string[len] = '\0';
    return str;
}

KlString
KlStringMatch(argc, argv)
    int argc;
    KlString argv[];

{
    int i;
    KlList kl_list;
    regexp *prog;
    int free_prog = 0;

    if (argc < 2)
	return (KlString) KlBadNumberOfArguments(argc);
    if (KlIsARegexp(argv[0])) {
	prog = ((KlRegexp) argv[0])->prog;
    } else {
	KlMustBeString(argv[0], 0);
	/* compile reg. expr */
	prog = Klregcomp(argv[0]->string);
	free_prog = 1;
    }
    KlMustBeString(argv[1], 1);

    if (Klregexec(prog, argv[1]->string)) {
	switch (argc) {
	case 2:
	    if (free_prog)
		KlRegexpProgFree(prog);
	    return (KlString) argv[1];

	case 3: {
	    KlString klstr;
	    KlMustBeNumber(argv[2], 2);
	    klstr = KlStringMatchAux(prog, ((KlNumber) argv[2])->number);
	    if (free_prog)
		KlRegexpProgFree(prog);
	    return klstr;
	}

	default:
	    KlListNMakeZ(kl_list, argc - 2);
	    for (i = 2; i < argc; i++) {
		KlMustBeNumber(argv[i], i);
		KlListStore(kl_list, i - 2,
			    KlStringMatchAux(prog,
					     ((KlNumber) argv[i])->number));
	    }
	}
    } else {
	kl_list = (KlList) NIL;
    }
    if (free_prog)
	KlRegexpProgFree(prog);
    return (KlString) kl_list;
}

/* The error handler for regular expressions, called by regexp
 * possible messages:
 * 
 * for regexp:
 * 
 * NULL parameter
 * corrupted program
 * memory corruption
 * corrupted pointers
 * internal foulup
 * corrupted opcode
 * 
 * for Kl_regsub:
 * 
 * NULL parm to Kl_regsub
 * damaged regexp fed to Kl_regsub
 * damaged match string
 */

void
Kl_regerror(msg)
    char *msg;
{
    KlError1s(KlE_BAD_REGEXPR, msg);
}

/*
 * modified version of Kl_regsub: (from  Henry Spencer's Kl_regsub)
 * returns dest which is malloced and expanded at will
 * sets dest length into out parameter size
 */

#ifndef KLCHARBITS
#define	UCHARAT(p)	((int)*(unsigned char *)(p))
#else
#define	UCHARAT(p)	((int)*(p)&KLCHARBITS)
#endif

/*
 - Kl_regsub - perform substitutions after a regexp match
 */
char *
Kl_regsub(prog, source, sizep)
    regexp *prog;
    char *source;
    int *sizep;				/* will be set to size of dest */
{
    register char *src;
    register char *dst;
    register char c;
    register int no;
    register int len;
    char *dest = (char *) Malloc(12);
    char *lastdest = dest+11;		/* last allowable - 1 */

    if (prog == NULL || source == NULL) {
	Kl_regerror("NULL parm to regsub");
	/*NOTREACHED*/
    }
    if (UCHARAT(prog->program) != REGMAGIC) {
	Kl_regerror("damaged regexp fed to regsub");
	/*NOTREACHED*/
    }

    src = source;
    dst = dest;
    while ((c = *src++) != '\0') {
	if (c == '&')
	    no = 0;
	else if (c == '\\' && '0' <= *src && *src <= '9')
	    no = *src++ - '0';
	else
	    no = -1;

	if (no < 0) {			/* Ordinary character. */
	    if (dst + 1 >= lastdest) {
		char *olddest = dest;
		int newlength = ((lastdest - dest) + 5) * 2 - 4;
		dest = (char *) Realloc(dest, newlength);
		lastdest = dest + (newlength - 1);
		dst = dest + (dst - olddest);
	    }
	    *dst++ = c;
	} else if (prog->startp[no] != NULL && prog->endp[no] != NULL) {
	    len = prog->endp[no] - prog->startp[no];
	    if (dst + len >= lastdest) {
		char *olddest = dest;
		int newlength = ((lastdest - dest) + 5) * 2 - 4;

		while (newlength <= (dst - dest) + len)
		    newlength = ((newlength) + 5) * 2 - 4;
		dest = (char *) Realloc(dest, newlength);
		lastdest = dest + (newlength - 1);
		dst = dest + (dst - olddest);
	    }
	    
	    (void) strncpy(dst, prog->startp[no], len);
	    dst += len;
	    if (dst > dest && *(dst-1) == '\0') {	/* strncpy hit NUL. */
		Kl_regerror("damaged match string");
		/*NOTREACHED*/
	    }
	}
    }
    *sizep = (dst - dest);
    *dst = '\0';
    return dest;
}

#ifdef DEBUG
/* some debugging code from Klone */
extern int regnarrate;
extern void Klregdump();

KlO
KlRegdump(obj)
    KlRegexp obj;
{
    KlMustBeRegexp(obj, 0);
    Klregdump(obj->prog);
    return (KlO) obj;
}

#endif /* DEBUG */

/*****************************************************************************\
* 				 string utils                                 *
\*****************************************************************************/
/*
 * KlUnstripString puts back \, ", etc... into string
 * copies string raw_string to string stripped_string
 * returns pointer to static storage
 * Does not add the enclosing "
 */

static unsigned char *stripped_string;
static int stripped_string_limit;
#define KlUnstripStringMargin 6

char *
KlUnstripString(len, raw_string)
    int len;
    unsigned char *raw_string;
{
    unsigned char *p, *q, *start, *limit, *end;
    int i;

    q = start = (unsigned char *) stripped_string;
    end = (unsigned char *) raw_string + len;
    limit = start + stripped_string_limit - KlUnstripStringMargin;
    for (p = (unsigned char *) raw_string; p<end; p++, q++) {
	if (q > limit) {
	    stripped_string_limit = stripped_string_limit ?
		stripped_string_limit * 2 + 4 : 60;
	    stripped_string = (unsigned char *)
		Realloc(stripped_string, stripped_string_limit);
	    q = (unsigned char *) stripped_string + (q - start);
	    limit = (unsigned char *) stripped_string + stripped_string_limit
		- KlUnstripStringMargin;
	    start = (unsigned char *) stripped_string;
	}
	switch (*p) {
	case '\\':
	    (*q++) = '\\';
	    *q = '\\';
	    break;
	case '"':
	    (*q++) = '\\';
	    *q = '\"';
	    break;
	case '\n':
	    if (KlQuoteNewlines) {
		(*q++) = '\\';
		*q = 'n';		
	    } else {
		*q = '\n';
	    }
	    break;
	case '\r':
	    (*q++) = '\\';
	    *q = 'r';
	    break;
	case '\t':
	    /* Old: we quoted tab, not necessary anymore
	       (*q++) = '\\';
	       *q = 't';
	       */
	    *q = '\t';
	    break;
	case '\033':
	    (*q++) = '\\';
	    *q = 'e';
	    break;
	default:
	    if ((*p) < ' ' || (*p) > '~') {
		/* not printable character */
		(*q++) = '\\';
		(*q++) = 'x';
		i = ((int) (*p)) / 16;
		(*q++) = (char) (i > 9 ? (i - 10) + 'a' : i + '0');
		i = ((int) (*p)) % 16;
		(*q) = (char) (i > 9 ? (i - 10) + 'a' : i + '0');
	    } else {
		*q = *p;
	    }
	}
    }
    KlUnstripStringLength = q - stripped_string;
    (*q++) = '\0';
    return (char *) stripped_string;
}

/*****************************************************************************\
* 				KlStripString                                 *
\*****************************************************************************/
/* parses an external representation of a Klone string, and returns the byte
 * array of its raw characters. The length is returned into the int
 * pointed to by lenptr, and is necessary since null chars can be specified
 * in the string!
 * Returns a pointer to a statically allocated space.
 */

/* KlStripStringContents: the containing double quotes are NOT included in 
 * raw_string !!!
 */

char *
KlStripStringContents(len, raw_string, lenptr)
    int len;
    unsigned char *raw_string;
    int *lenptr;
{
    unsigned char *p = raw_string, *q, *end = p+len;
    unsigned int num;

    if (len > stripped_string_limit) {
	/* check we have enough room in our work buffer */
	stripped_string_limit = len;
	stripped_string = (unsigned char *)
	    Realloc(stripped_string, stripped_string_limit + 1);
    }
    for (q = stripped_string; p < end; p++, q++) {
	switch (*p) {
	case '\\':
	    switch (*(++p)) {
	    case '\n':
		q--;
		break;
	    case 'n':
		*q = '\n';
		break;
	    case 'r':
		*q = '\r';
		break;
	    case 't':
		*q = '\t';
		break;
	    case 'e':
		*q = '\033';
		break;
	    case 'x':
		num = 0;
		p++;
		if (isxdigit(*p)) {
		    num = (*p <= '9' ? *p - '0'
			   : (*p >= 'a' ? *p - 'W' : *p -'7'));
		    p++;
		    if (isxdigit(*p)) {
			num <<= 4;
			num += (*p <= '9' ? *p - '0'
				: (*p >= 'a' ? *p - 'W' : *p -'7'));
		    } else {
			p--;
		    }
		    *q = num;
		} else {
		    *q = *(--p);
		}
		break;
	    default:
		if ((*p <= '7') && (*p >= '0')) {
		    num = *p++ - '0';
		    if ((*p <= '7') && (*p >= '0')) {
			num <<= 3;
			num += *p++ - '0';
			if ((*p <= '7') && (*p >= '0')) {
			    num <<= 3;
			    num += *p - '0';
			} else {
			    p--;
			}
		    } else {
			p--;
		    }
		    *q = num;
		} else {
		    *q = *p;
		}
	    }
	    break;
	default:
	    *q = *p;
	}
    }
    *q = '\0';
    *lenptr = (q - stripped_string);
    return (char *) stripped_string;
}

/* old version for back-compat. here the enclosing double quotes are included
 * in string
 */

char *
KlStripString(len, raw_string, lenptr)
    int len;
    unsigned char *raw_string;
    int *lenptr;
{
    return KlStripStringContents(len - 2, raw_string + 1, lenptr);
}

/* parses symbolic names of characters
 * add names to KlSymbCharParseTable
 */

struct KlCharDefPair {
    char *name;
    int value;
};

static struct KlCharDefPair KlSymbCharParseTable[] = {
    {"space", ' '},
    {"newline", '\n'},
    {"backspace", 8},
    {"rubout", 127},
    {"tab", 9},
    {0, 0}
};

int
KlSymbCharParse(string)
    char *string;
{
    int i = 0;

    while (KlSymbCharParseTable[i].name) {
	if (!strcmp(string, KlSymbCharParseTable[i].name)) {
	    return KlSymbCharParseTable[i].value;
	}
	i++;
    }
    return -1;
}

/* KlStrdup
 * a strdup-like, but with Klone's malloc
 */

char *
KlStrdup(s)
    char *s;
{
    char *duplicate = (char *) Malloc(strlen(s) + 1);
    strcpy(duplicate, s);
    return duplicate;
}
/*****************************************************************************\
* 				  upperlower                                  *
\*****************************************************************************/

KlO
KlStringToUpper(string)
    KlString string;
{
    KlString result;
    char *p, *q, *end;
    KlMustBeString(string, 0);
    p = string->string;
    end = p + KlStringLength(string);
    result = KlStringNMake(end - p);
    q = result->string;
    while (p < end) {
	if (islower(*p))
	    *q++ = *p++ - 32;
	else
	    *q++ = *p++;
    }
    *q = *p;				/* trailing 0 */
    return (KlO) result;
}

KlO
KlStringToLower(string)
    KlString string;
{
    KlString result;
    char *p, *q, *end;
    KlMustBeString(string, 0);
    p = string->string;
    end = p + KlStringLength(string);
    result = KlStringNMake(end - p);
    q = result->string;
    while (p < end) {
	if (isupper(*p))
	    *q++ = *p++ + 32;
	else
	    *q++ = *p++;
    }
    *q = *p;				/* trailing 0 */
    return (KlO) result;
}

#ifdef NO_MEMSET

KlMemSet(s, c, n)
    char *s;
    int c;
    int n;
{
    char *end = s + n;
    while (s < end)
	*s++ = c;
}

#endif  /* NO_MEMSET */

/*****************************************************************************\
* 			Pointers to other string parts                        *
\*****************************************************************************/
/* should never be malloced / realloced */

KlStringPtr
KlStringPtrMake(l, s)
    int l;
    char *s;				/* the string itself */
{
    KlStringPtr object;

    object = (KlStringPtr) KlOMake(KlStringPtrType);
    object->string = s;
    object->size = l;
    object->refersto = 0;		/* you should put there the
					   reffered string if any */
    return object;
}

KlStringPtr
KlStringPtrMakeAndRefers(l, s, o)
    int l;
    char *s;				/* the string itself */
    KlO o;				/* object we dont want to GC */
{
     KlStringPtr object = KlStringPtrMake(l, s);
     KlIncRef(object->refersto = o);
     return object;
}

KlO
KlStringPtrFree(obj)
    KlStringPtr obj;
{
    KlDecRef(obj->refersto);
    Free(obj);
    return (KlO) obj;
}


KlO
KlStringPtrSub(argc, argv)
    int argc;
    KlString *argv;
{
    int from, to;

    switch (argc) {
    case 3:
	KlMustBeNumber(argv[2], 2);
	to = ((KlNumber) argv[2])->number;
	break;
    case 2:
	to = -1;
	break;
    default:
	return KlBadNumberOfArguments(argc);
    }
    KlMustBeNumber(argv[1], 1);
    KlMustBeString(argv[0], 0);
    from = ((KlNumber) argv[1])->number;
    if (to < 0)
	to = KlStringLength(*argv);
    return (KlO) KlStringPtrMakeAndRefers(to - from, 
					  (*argv)->string + from, *argv);
}

/*****************************************************************************\
* 				  TYPE INIT                                   *
\*****************************************************************************/

KlStringInit()
{
    stripped_string_limit = KlMAX_TEMP_STRING_SIZE;
    stripped_string = (unsigned char *) Malloc(stripped_string_limit);

    KlDeclareType(&KlStringType, "String", sizeof(struct _KlString));
    KlDeclareIsTrait(KlStringType, KlTrait_string);

    KlA_String = KlTypeName(KlStringType);

    KlDeclareMethod1(KlStringType, KlSelPrint, KlStringPrint);
    KlDeclareMethod1(KlStringType, KlSelFree, KlStringFree);
    KlDeclareMethod1(KlStringType, KlSelEqual, KlStringEqual);
    KlDeclareMethod1(KlStringType, KlSelAdd, KlStringAdd);
    KlDeclareMethod1(KlStringType, KlSelCopy, KlStringCopy);
    KlDeclareMethod1(KlStringType, KlSelGet, KlStringGet);
    KlDeclareMethod1(KlStringType, KlSelPut, KlStringPut);
    KlDeclareMethod1(KlStringType, KlSelInsert, KlStringInsert);
    KlDeclareMethod1(KlStringType, KlSelDelete, KlStringDelete);
    KlDeclareMethod1(KlStringType, KlSelNth, KlStringNth);
    KlDeclareMethod1(KlStringType, KlSelHash, KlStringHash);
    KlDeclareMethod1(KlStringType, KlSelLength, KlStringLengthKl);
    KlDeclareMethod1(KlStringType, KlSelCompare, (KlMethod) KlStringCompare);
    KlDeclareMethod1(KlStringType, KlSelDolist, (KlMethod) KlStringDolist);

    /* bootstrap: make atoms sons of strings */
    KlTypeFatherSet(KlAtomType, KlStringType);

    KlDeclareSubr(KlStringMatch, "match", NARY);
    KlDeclareSubr(KlStringToUpper, "toupper", 1);
    KlDeclareSubr(KlStringToLower, "tolower", 1);
    KlDeclareSubr(KlStringNMakeKl, "make-string", NARY);

    KlIncRef(KlNilString = KlStringMake("")); /* NIL_STRING */
    KlIncRef(KlPackage = KlNilString);

   /* KlStringPtr is a KlString which does not free the C string at GC */
    KlDeclareSubType(&KlStringPtrType, "StringPtr", KlStringType,
		     sizeof(struct _KlStringPtr));
    KlDeclareTrait(KlStringPtrType, KlTrait_unreallocable);
    KlDeclareMethod1(KlStringPtrType, KlSelFree, KlNumberFree);
    KlDeclareSubr(KlStringPtrSub, "substring-ptr", NARY);

    KlDeclareSubType(&KlRegexpType, "Regexp", KlStringType,
		     sizeof(struct _KlRegexp));
    KlDeclareTrait(KlRegexpType, KlTrait_unreallocable);

    KlDeclareMethod1(KlRegexpType, KlSelFree, KlRegexpFree);
    KlDeclareMethod1(KlRegexpType, KlSelGet, KlRegexpGet);
    KlDeclareMethodUndefined(KlRegexpType, KlSelPut);
    KlDeclareMethodUndefined(KlRegexpType, KlSelDelete);
    KlDeclareMethodUndefined(KlRegexpType, KlSelInsert);
    KlDeclareMethod1(KlRegexpType, KlSelExecute, KlRegexpExecute);
    KlDeclareMethod1(KlRegexpType, KlSelApply, KlRegexpApply);

    KlDeclareSubr(KlRegcomp, "regcomp", 1);
    KlDeclareSubr(KlRegexec, "regexec", NARY);
    KlDeclareSubr(KlRegsub, "regsub", NARY);

#ifdef DEBUG
    KlDeclareSubr(KlRegdump, "regdump", 1);
    KlActivePointerToIntMake("regnarrate", &regnarrate);
#endif /* DEBUG */

}