Sapphire Lisp

Fork

/* Copyright (c) 2020 AlaskanEmily
 *
 * This software is provided 'as-is', without any express or implied warranty.
 * In no event will the authors be held liable for any damages arising from
 * the use of this software.
 *
 * Permission is granted to anyone to use this software for any purpose,
 * including commercial applications, and to alter it and redistribute it
 * freely, subject to the following restrictions:
 *
 * 1. The origin of this software must not be misrepresented; you must not
 *   claim that you wrote the original software. If you use this software in a
 *   product, an acknowledgment in the product documentation would be
 *   appreciated but is not required.
 * 2. Altered source versions must be plainly marked as such, and must not be
 *   misrepresented as being the original software.
 * 3. This notice may not be removed or altered from any source distribution.
 */

#include "sl_x.h"

/*****************************************************************************/

const struct SL_S_Atom sl_x_integers[SL_X_N_INTEGERS] = {
    SL_S_STATIC_ATOM("0"),
    SL_S_STATIC_ATOM("1"),
    SL_S_STATIC_ATOM("2"),
    SL_S_STATIC_ATOM("3"),
    SL_S_STATIC_ATOM("4"),
    SL_S_STATIC_ATOM("5"),
    SL_S_STATIC_ATOM("6"),
    SL_S_STATIC_ATOM("7"),
    SL_S_STATIC_ATOM("8"),
    SL_S_STATIC_ATOM("9"),
    SL_S_STATIC_ATOM("10"),
    SL_S_STATIC_ATOM("11"),
    SL_S_STATIC_ATOM("12"),
    SL_S_STATIC_ATOM("13"),
    SL_S_STATIC_ATOM("14"),
    SL_S_STATIC_ATOM("15"),
};

/*****************************************************************************/

#define SL_X_ATOM(X, TXT) const struct SL_S_Atom X = SL_S_STATIC_ATOM(TXT)
#define SL_X_HINT(X) const struct SL_S_Atom sl_x_ ## X ## _hint = \
    SL_S_STATIC_ATOM("^" #X)

SL_X_ATOM(sl_x_nil,     "nil");
SL_X_ATOM(sl_x_true,    "true");
SL_X_ATOM(sl_x_false,   "false");
SL_X_HINT(list);
SL_X_HINT(atom);

#define SL_X_HINT_END(X) SL_X_HINT(X);
SL_X_INTEGRAL_TYPES(SL_X_HINT_END)
#undef SL_X_HINT_END

#ifdef SL_S_ENABLE_POINTERS
# define SL_X_PTR_HINT_END(X) \
    const struct SL_S_Atom sl_x_ptr_ ## X ## _hint = \
    SL_S_STATIC_ATOM("^ptr-" #X);
SL_X_INTEGRAL_TYPES(SL_X_PTR_HINT_END)
# undef SL_X_PTR_HINT_END
#endif

SL_X_ATOM(sl_x_defun,   "defun");
SL_X_ATOM(sl_x_def,     "def");
SL_X_ATOM(sl_x_defrec,  "defrec");
SL_X_ATOM(sl_x_defproto,"defproto");
SL_X_ATOM(sl_x_if,      "if");
SL_X_ATOM(sl_x_let,     "let");
SL_X_ATOM(sl_x_plus,    "+");
SL_X_ATOM(sl_x_minus,   "-");
SL_X_ATOM(sl_x_times,   "*");
SL_X_ATOM(sl_x_divide,  "/");
SL_X_ATOM(sl_x_mod,     "%");
SL_X_ATOM(sl_x_comment, "comment");
SL_X_ATOM(sl_x_dot,     ".");
SL_X_ATOM(sl_x_tick,    "'");
SL_X_ATOM(sl_x_shift_left,"<<");
SL_X_ATOM(sl_x_shift_right,">>");
SL_X_ATOM(sl_x_bit_or,  "|");
SL_X_ATOM(sl_x_bit_and, "&");
SL_X_ATOM(sl_x_bit_xor, "^");
SL_X_ATOM(sl_x_bit_not, "~");
SL_X_ATOM(sl_x_is_nil,  "nil?");
SL_X_ATOM(sl_x_is_atom, "atom?");
SL_X_ATOM(sl_x_is_list, "list?");
SL_X_ATOM(sl_x_is_int,  "int?");
SL_X_ATOM(sl_x_concat,  "++");
SL_X_ATOM(sl_x_cons,    "cons");
SL_X_ATOM(sl_x_head,    "head");
SL_X_ATOM(sl_x_tail,    "tail");
SL_X_ATOM(sl_x_index,   "index");
SL_X_ATOM(sl_x_not,     "!");
SL_X_ATOM(sl_x_eq,      "=");
SL_X_ATOM(sl_x_ne,      "!=");
SL_X_ATOM(sl_x_gt,      ">");
SL_X_ATOM(sl_x_ge,      ">=");
SL_X_ATOM(sl_x_lt,      "<");
SL_X_ATOM(sl_x_le,      "<=");

/*****************************************************************************/

const struct SL_S_Atom *const sl_x_all_hints[] = {
    &sl_x_list_hint,
    &sl_x_atom_hint,

#define SL_X_HINT_REF(X) &(sl_x_ ## X ## _hint),
SL_X_INTEGRAL_TYPES(SL_X_HINT_REF)
#undef SL_X_HINT_REF

#ifdef SL_S_ENABLE_POINTERS
# define SL_X_PTR_HINT_REF(X) &(sl_x_ptr_ ## X ## _hint),
SL_X_INTEGRAL_TYPES(SL_X_PTR_HINT_REF)
# undef SL_X_PTR_HINT_REF
#endif
    SL_S_NIL
};

/*****************************************************************************/

static int sl_x_is_builtin(const struct SL_S_Atom *arg){
    return (SL_S_IS_NIL(arg) || arg->len > 5) ? 1 : !(
        SL_S_COMPARE_ATOMS(&sl_x_if, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_let, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_plus, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_minus, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_times, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_divide, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_mod, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_shift_left, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_shift_right, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_bit_or, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_bit_and, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_bit_xor, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_bit_not, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_is_nil, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_is_atom, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_is_list, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_is_int, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_concat, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_cons, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_head, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_tail, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_index, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_not, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_eq, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_ne, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_gt, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_ge, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_lt, arg) ||
        SL_S_COMPARE_ATOMS(&sl_x_le, arg));
}

/*****************************************************************************/

static int sl_x_parse_int(const struct SL_S_Atom *arg, int *out){
    register sl_s_len_t i;
    register char c;
    int r;
    unsigned short is_neg;
    
    if(SL_S_IS_NIL(arg) || arg->len < 1)
        return 1;
    
    r = 0;
    c = arg->text[0];
    if(c == '-'){
        if(arg->len < 2)
            return 1;
        c = arg->text[1];
        is_neg = 1;
        i = 1;
    }
    else if(c == '+'){
        if(arg->len < 2)
            return 1;
        c = arg->text[1];
        is_neg = 0;
        i = 1;
    }
    else{
        is_neg = 0;
        i = 0;
    }
    
    if(c == '0'){
        if(arg->len > i + 1 &&
            (arg->text[i + 1] == 'x' || arg->text[i + 1] == 'X')){
            for(i += 2; i < arg->len; i++){
                c = arg->text[i];
                r <<= 4;
                if(c >= 'a' && c <= 'f')
                    c = c - 'a' + 10;
                else if(c >= 'A' && c <= 'F')
                    c = c - 'A' + 10;
                else if(c >= '0' && c <= '9')
                    c = c - '0';
                else
                    return 1;
                r += c;
            }
        }
        else if(arg->len > 2 &&
            (arg->text[i + 1] == 'b' || arg->text[i + 1] == 'B')){
            
            for(i += 2; i < arg->len; i++){
                c = arg->text[i];
                r <<= 1;
                if(c == '1')
                    r |= 1;
                if(c != '0')
                    return 1;
            }
        }
        else{
            for(i += 1; i < arg->len; i++){
                /* Octal. */
                c = arg->text[i];
                r <<= 3;
                if(c >= '0' && c <= '7')
                    r += c - '0';
                else
                    return 1;
            }
        }
    }
    else{
        for(; i < arg->len; i++){
                c = arg->text[i];
                r *= 10;
                if(c >= '0' && c <= '9')
                    r += c - '0';
                else
                    return 1;
        }
    }
    if(is_neg)
        r = -r;
    *out = r;
    return 0;
}

/*****************************************************************************/

SL_S_PURE_FUNC(int) SL_X_IsRuntimeConstant(const void *value){
    int tag;
    void *data;
    struct SL_S_Atom *head;
    struct SL_S_List *list;
recurse:
    SL_S_PTR_TAG_DATA(value, data, tag);
    if(SL_S_IS_NIL(data))
        return 0;
    
    switch(tag){
        case SL_S_ATOM_TAG:
            if(SL_S_COMPARE_ATOMS(&sl_x_nil, (struct SL_S_Atom*)data))
                return 0;
            return sl_x_parse_int(data, &tag);
        case SL_S_LIST_TAG:
            list = data;
            if(SL_S_IS_NIL(list->head))
                goto check_tail;
            
            if(SL_S_IS_LIST(list->head)){
                if(SL_X_IsRuntimeConstant(list->head) != 0)
                    return 1;
                goto check_tail;
            }
            
            head = SL_S_PTR_FROM_TAG(list->head);
            if(SL_S_COMPARE_ATOMS(&sl_x_comment, head))
                return 0;
            
            if(SL_S_COMPARE_ATOMS(&sl_x_dot, head)){
                value = list->head;
                goto recurse;
            }
            
            if(SL_S_COMPARE_ATOMS(&sl_x_tick, head)
                || sl_x_is_builtin(head) == 0){
                
                goto check_tail;
            }
            
            return 1;
        default:
#if (defined __GNUC__)
            __builtin_unreachable();
#elif (defined _MSC_VER)
            __assume(0);
#endif
    }
    
check_tail:
    while((list = list->tail) != SL_S_NIL){
        if(list->tail == SL_S_NIL){
            value = list->head;
            goto recurse;
        }
        
        if(SL_X_IsRuntimeConstant(list->head) != 0)
            return 1;
    }
    return 0;
}

/*****************************************************************************/

SL_S_PURE_FUNC(int) SL_X_IsInt(const struct SL_S_Atom *arg){
    int unused;
    return sl_x_parse_int(arg, &unused);
}

/*****************************************************************************/

SL_S_FUNC(void) SL_X_IsIntCB(const void *value, unsigned char *out_flag){
    if(*out_flag == 0)
        return;
    *out_flag = SL_S_IS_ATOM(value) &&
        SL_X_IsInt(SL_S_PTR_FROM_TAG(value)) == 0;
}

/*****************************************************************************/

SL_S_PURE_FUNC(int) SL_X_ParseInt(const struct SL_S_Atom *arg){
    int r;
    r = 0;
    sl_x_parse_int(arg, &r);
    return r;
}

/*****************************************************************************/

SL_S_PURE_FUNC(int) SL_X_TryParseInt(const struct SL_S_Atom *arg, int *out){
    return sl_x_parse_int(arg, out);
}

/*****************************************************************************/

SL_S_PURE_FUNC(int) SL_X_IsDefun(const struct SL_S_List *code){
    if(!SL_S_IS_NIL(code) &&
        SL_S_IS_ATOM(code->head) &&
        !SL_S_IS_NIL(code->tail) &&
        SL_S_IS_ATOM(code->tail->head) &&
        !SL_S_IS_NIL(code->tail->tail) &&
        SL_S_IS_LIST(code->tail->tail->head) &&
        SL_S_COMPARE_ATOMS(&sl_x_defun,
            (struct SL_S_Atom*)SL_S_PTR_FROM_TAG(code->head))){
        
        return 0;
    }
    return -1;
}

/*****************************************************************************/
#define SL_X_DEF_ARITY1 3
static const unsigned char sl_x_def_flags1[SL_X_DEF_ARITY1] = {
    SL_S_IN_ATOM,
    SL_S_OUT_ATOM,
    SL_S_OUT_ANY
};

#define SL_X_DEF_ARITY2 4
static const unsigned char sl_x_def_flags2[SL_X_DEF_ARITY2] = {
    SL_S_IN_ATOM,
    SL_S_OUT_ATOM,
    SL_S_OUT_ATOM,
    SL_S_OUT_ANY
};

#define SL_X_DEF_MAX_ARITY 4

SL_S_PURE_FUNC(int) SL_X_IsDef(const struct SL_S_List *code){
    const void *args[SL_X_DEF_MAX_ARITY];
    args[0] = SL_S_MK_ATOM(&sl_x_def);
    
    /* Check for form 1. */
    if(SL_S_Match(code,
            args,
            sl_x_def_flags1,
            SL_X_DEF_ARITY1,
            SL_X_DEF_ARITY1) == SL_X_DEF_ARITY1 ||
        SL_S_Match(code,
            args,
            sl_x_def_flags2,
            SL_X_DEF_ARITY2,
            SL_X_DEF_ARITY2) == SL_X_DEF_ARITY2){
        
        return 0;
    }
    else{
        return 1;
    }
}

/*****************************************************************************/
#define SL_X_DEFREC_MIN_ARITY 2
static const unsigned char sl_x_defrec_flags[SL_X_DEFREC_MIN_ARITY] = {
    SL_S_IN_ATOM,
    SL_S_OUT_ATOM
};

SL_S_PURE_FUNC(int) SL_X_IsDefrec(const struct SL_S_List *code){
    const void *args[SL_X_DEFREC_MIN_ARITY];
    int arity;
    
    args[0] = SL_S_MK_ATOM(&sl_x_defrec);
    
    arity = SL_S_Match(code,
        args,
        sl_x_defrec_flags,
        SL_X_DEFREC_MIN_ARITY,
        SL_X_DEFREC_MIN_ARITY);
    
    if(arity == SL_X_DEFREC_MIN_ARITY){
        return 0;
    }
    else if(arity < 0 && (arity = -arity) > SL_X_DEFREC_MIN_ARITY){
        /* Test for the correct form in the fields. */
        code = code->tail->tail;
        do{
            if(!SL_S_IS_ATOM(code->head))
                return 1;
        }while((code = code->tail) != SL_S_NIL);
        return 0;
    }
    else{
        return 1;
    }
}

/*****************************************************************************/

SL_S_PURE_FUNC(int) SL_X_IsDefproto(const struct SL_S_List *code){
    if(!SL_S_IS_NIL(code) &&
        SL_S_IS_ATOM(code->head) &&
        !SL_S_IS_NIL(code->tail) &&
        SL_S_IS_ATOM(code->tail->head) &&
        SL_S_COMPARE_ATOMS(&sl_x_defproto,
            (struct SL_S_Atom*)SL_S_PTR_FROM_TAG(code->head))){
        
        return 0;
    }
    return -1;
}

/*****************************************************************************/

SL_S_FUNC(int) SL_X_ParseDefun(const struct SL_S_List *code,
    const struct SL_S_Atom **out_name,
    const struct SL_S_List **out_args,
    const struct SL_S_List **out_body){
    
    if(SL_X_IsDefun(code) != 0)
        return -1;
    
    *out_name = SL_S_PTR_FROM_TAG(code->tail->head);
    *out_args = SL_S_PTR_FROM_TAG(code->tail->tail->head);
    *out_body = SL_S_PTR_FROM_TAG(code->tail->tail->tail);
    return 0;
}

/*****************************************************************************/

SL_S_FUNC(int) SL_X_ParseDef(const struct SL_S_List *code,
    const struct SL_S_Atom **out_hint,
    const struct SL_S_Atom **out_name,
    const void **out_value){
    
    const void *args[SL_X_DEF_MAX_ARITY];
    args[0] = SL_S_MK_ATOM(&sl_x_def);
    
    if(SL_S_Match(code,
        args,
        sl_x_def_flags1,
        SL_X_DEF_ARITY1,
        SL_X_DEF_ARITY1) == SL_X_DEF_ARITY1){
        
        /* No hint */
        *out_hint = SL_S_NIL;
        *out_name = SL_S_PTR_FROM_TAG(code->tail->head);
        *out_value = code->tail->tail->head;
        return 0;
    }
    else if(SL_S_Match(code,
        args,
        sl_x_def_flags2,
        SL_X_DEF_ARITY2,
        SL_X_DEF_ARITY2) == SL_X_DEF_ARITY2){
        
        /* With hint */
        *out_hint = SL_S_PTR_FROM_TAG(code->tail->head);
        /* Check if the hint is valid */
        if((*out_hint)->len <= 1 || (*out_hint)->text[0] != '^'){
            return 1;
        }
        
        *out_name = SL_S_PTR_FROM_TAG(code->tail->tail->head);
        *out_value = code->tail->tail->tail->head;
        return 0;
    }
    else{
        return 1;
    }
}

/*****************************************************************************/

static struct SL_S_List *sl_x_add_rec_field(
    const struct SL_S_Atom *name,
    const struct SL_S_Atom *hint){
    
    struct SL_S_List *arg_pair, *to;
    
    arg_pair = SL_S_Malloc(sizeof(struct SL_S_List));
    arg_pair->ref = 1;
    arg_pair->tail = SL_S_Malloc(sizeof(struct SL_S_List));
    arg_pair->tail->ref = 1;
    arg_pair->tail->tail = SL_S_NIL;
    
    arg_pair->head = SL_S_MK_ATOM(hint);
    arg_pair->tail->head = SL_S_MK_ATOM(name);
    
    to = SL_S_Malloc(sizeof(struct SL_S_List));
    to->ref = 1;
    to->head = SL_S_MK_LIST(arg_pair);
    return to;
}

SL_S_FUNC(int) SL_X_ParseDefrec(const struct SL_S_List *code,
    const struct SL_S_Atom **out_name,
    const struct SL_S_List **out_fields){
    
    const struct SL_S_Atom *name, *hint;
    struct SL_S_List *ret, **dest;
    register const struct SL_S_Atom *atom;
    register const struct SL_S_Atom **target;
    
    *out_name = SL_S_PTR_FROM_TAG(code->tail->head);
    code = code->tail->tail;
    if(code == SL_S_NIL){
        *out_fields = SL_S_NIL;
        return 0;
    }
    
    dest = &ret;
    do{
        atom = SL_S_PTR_FROM_TAG(code->head);
        SL_S_INCREF(atom);
        if(atom->len > 1 && atom->text[0] == '^')
            target = &hint;
        else
            target = &name;
        if(*target != SL_S_NIL){
            *dest = sl_x_add_rec_field(hint, name);
            dest = &((*dest)->tail);
        }
        *target = atom;
    }while((code = code->tail) != SL_S_NIL);
    
    if(hint != SL_S_NIL || name != SL_S_NIL){
        *dest = sl_x_add_rec_field(hint, name);
        (*dest)->tail = SL_S_NIL;
    }
    else{
        *dest = SL_S_NIL;
    }
    *out_fields = ret;
    return 0;
}

/*****************************************************************************/
/* Returns 0 on success.
 * This DOES incref the methods, unlike most other parsers.
 * This does no incref the name.
 */
SL_S_FUNC(int) SL_X_ParseDefproto(const struct SL_S_List *code,
    const struct SL_S_Atom **out_name,
    const struct SL_S_List **out_methods){
    
    if(SL_X_IsDefproto(code) != 0)
        return -1;
    
    *out_name = SL_S_PTR_FROM_TAG(code->tail->head);
    *out_methods = SL_S_PTR_FROM_TAG(code->tail->tail);
    return 0;
    
}

/*****************************************************************************/

static struct SL_S_List *sl_x_create_args(const struct SL_S_Atom *hint,
    const struct SL_S_Atom *name){
    
    struct SL_S_List *list;
    
    list = SL_S_Malloc(sizeof(struct SL_S_List));
    list->ref = 1;
    list->head = (hint == SL_S_NIL) ? SL_S_NIL : SL_S_MK_ATOM(hint);
    list->tail = SL_S_Malloc(sizeof(struct SL_S_List));
    list->tail->ref = 1;
    list->tail->head = (name == SL_S_NIL) ? SL_S_NIL : SL_S_MK_ATOM(name);
    list->tail->tail = SL_S_NIL;
    SL_S_INCREF(hint);
    SL_S_INCREF(name);
    return list;
}

/*****************************************************************************/

SL_S_FUNC(struct SL_S_List) *SL_X_ParseArgs(const struct SL_S_List *args){
    struct SL_S_Atom *hint, *name;
    register struct SL_S_Atom *value, **target;
    struct SL_S_List *ret, **dest;
    if(SL_S_IS_NIL(args))
        return SL_S_NIL;
    
    hint = SL_S_NIL;
    name = SL_S_NIL;
    dest = &ret;
    do{
        if(!SL_S_IS_ATOM(args->head))
            goto fail;
        value = SL_S_PTR_FROM_TAG(args->head);
        if(value->len > 0 && value->text[0] == '^')
            target = &hint;
        else
            target = &name;
        
        if(*target != SL_S_NIL){
            *dest = SL_S_Malloc(sizeof(struct SL_S_List));
            (*dest)->head = sl_x_create_args(hint, name);
            dest = &((*dest)->tail);
            hint = SL_S_NIL;
            name = SL_S_NIL;
        }
        *target = value;
    }while((args = args->tail));
    
    if(hint != SL_S_NIL || name != SL_S_NIL){
        *dest = SL_S_Malloc(sizeof(struct SL_S_List));
        (*dest)->head = sl_x_create_args(hint, name);
        dest = &((*dest)->tail);
    }
    *dest = SL_S_NIL;
    return ret;
fail:
    *dest = SL_S_NIL;
    SL_S_DECREF(ret); /* This should recurse on down. */
    return SL_S_NIL;
}

/*****************************************************************************/

#define SL_I_BUFFER_INIT 256
#define SL_I_BUFFER_DOUBLE 4096

/*****************************************************************************/

SL_S_FUNC(struct SL_S_Atom) *SL_X_BufferFile(const struct SL_X_FileOps *ops,
    const struct SL_S_Atom *name){
    
    void *file;
    struct SL_S_Atom *to;
    char *old;
    sl_s_len_t cap;
    
    /* TODO: Also try the system include directories */
    file = ops->open_read(name->text);
    
    if(!file)
        return SL_S_NIL;
    
    cap = 0;
    
    to = SL_S_Malloc(sizeof(struct SL_S_Atom));
    to->ref = 1;
    to->text = (void*)0;
    to->len = 0;
    do{
        old = to->text;
        if(cap == 0){
            cap = SL_I_BUFFER_INIT;
        }
        else if(cap < SL_I_BUFFER_DOUBLE){
            cap <<= 1;
        }
        else{
            if(SL_S_MAX_LEN - SL_I_BUFFER_DOUBLE < cap){
                /* over-length. Just stop reading the file. Sorry. */
                if(SL_S_MAX_LEN == cap)
                    break;
                else
                    cap = SL_S_MAX_LEN;
            }
            else{
                cap += SL_I_BUFFER_DOUBLE;
            }
        }
        
        to->text = SL_S_Malloc(cap);
        if(!to->text){
            /* OOM */
            if(old)
                SL_S_Free(old);
            return SL_S_NIL;
        }
        if(old){
            SL_S_MemCopy(to->text, old, to->len);
            SL_S_Free(old);
        }
        to->len += ops->read(file, to->text + to->len, cap - to->len);
    }while(!ops->is_eof(file));
    
    ops->close(file);
    
    return to;
}

/*****************************************************************************/

SL_S_FUNC(void) SL_X_MeasureAtomsCB(const void *value, void *arg){
    struct SL_X_MeasureResult *result;
    sl_s_len_t len;
    result = arg;
    
    if(result->flag)
        return;
    
    if(!SL_S_IS_ATOM(value)){
        result->flag = 1;
    }
    else{
        len = ((struct SL_S_Atom*)SL_S_PTR_FROM_TAG(value))->len;
        /* Check for overflow. */
        if(SL_S_MAX_LEN - len < result->len)
            result->flag = 1;
        else
            result->len += len;
    }
}

/*****************************************************************************/

SL_S_FUNC(void) SL_X_ConcatAtomsCB(const void *value, void *arg){
    struct SL_S_Atom *atom, *to;
    register sl_s_len_t len;
    atom = SL_S_PTR_FROM_TAG(value);
    to = arg;
    len = atom->len;
    
    SL_S_MemCopy(to->text + to->len, atom->text, len);
    to->len += len;
}

/*****************************************************************************/