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.
 */

/* itoa implementation (in SL_S_IntToAtom):
 * Copyright 1988-90 by Robert B. Stout dba MicroFirm
 * Released to public domain, 1991
 */

#include "sl_s.h"

/* TODO: Make this more modular. */
#include <stdlib.h>
#include <string.h>

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

SL_S_FUNC(void) SL_S_FreeValue(void *val){
    void *untagged;
    int tag;
    if(SL_S_IS_NIL(val))
        return;
    SL_S_PTR_TAG_DATA(val, untagged, tag);
    if(tag == SL_S_LIST_TAG){
        SL_S_FreeList(untagged);
    }
    else{
        SL_S_FREE_ATOM(untagged);
    }
}

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

SL_S_FUNC(void) SL_S_FreeList(struct SL_S_List *list){
    struct SL_S_List *tmp;
    while(!SL_S_IS_INTERNED(list)){
        SL_S_DECREF(list->head);
        tmp = list;
        list = list->tail;
        SL_S_Free(tmp);
        if(!SL_S_IS_INTERNED(list) &&
            SL_S_ATOMIC_DEC(&(list->ref)) == 1) {
            
            /* Still has refs, stop freeing. */
            return;
        }
    }
}

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

SL_S_FUNC(void) SL_S_FreeAtom(struct SL_S_Atom *atom){
    SL_S_FREE_ATOM(atom);
}

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

SL_S_MALLOC_FUNC(void) *SL_S_Malloc(unsigned len){
    if(len == 0)
        return (void*)0;
    else
        return malloc(len);
}

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

SL_S_FUNC(void) SL_S_Free(void *ptr){
    if(ptr != NULL)
        free(ptr);
}

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

SL_S_FUNC(void) SL_S_Free2(void *ptr1, void *ptr2){
    if(ptr1 != NULL)
        free(ptr1);
    if(ptr1 != NULL && ptr1 != ptr2)
        free(ptr2);
}

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

SL_S_PURE_FUNC(sl_s_len_t) SL_S_Length(const struct SL_S_List *list){
    sl_s_len_t i;
    i = 0;
    while(list){
        list = list->tail;
        i++;
        if(i == SL_S_MAX_LEN)
            break;
    }
    return i;
}

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

SL_S_PURE_FUNC(int) SL_S_LengthCompare(const struct SL_S_List *list,
    sl_s_len_t len){
    
    sl_s_len_t i;
    i = 0;
    while(list){
        list = list->tail;
        if(++i > len)
            return 1;
        if(i == SL_S_MAX_LEN)
            break;
    }
    
    return i == len ? 0 : 1;
}

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

SL_S_PURE_FUNC(void) SL_S_MemCopy(void *to, const void *from, sl_s_len_t len){
    memcpy(to, from, len);
}

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

SL_S_PURE_FUNC(void) SL_S_MemSet(void *to, int c, sl_s_len_t len){
    memset(to, c, len);
}

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

SL_S_PURE_FUNC(int) SL_S_MemComp(const void *a, const void *b, sl_s_len_t len){
    return memcmp(a, b, len);
}

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

SL_S_PURE_FUNC(unsigned) SL_S_CompareAtoms(const struct SL_S_Atom *a,
    const struct SL_S_Atom *b){
    return SL_S_COMPARE_ATOMS(a, b);
}

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

SL_S_PURE_FUNC(unsigned) SL_S_StrLen(const char *string){
    return strlen(string);
}

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

SL_S_FUNC(void) SL_S_ForEach(
    SL_S_FUNC_PTR(void, cb)(const void *value, void *arg),
    const struct SL_S_List *list,
    void *arg){
    
    if(SL_S_IS_NIL(list))
        return;
    
    do{
        cb(list->head, arg);
    }while((list = list->tail) != SL_S_NIL);
}

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

SL_S_FUNC(struct SL_S_List) *SL_S_Map(
    SL_S_FUNC_PTR(void*, cb)(const void *value, void *arg),
    const struct SL_S_List *list,
    void *arg){
    
    struct SL_S_List *ret, **dest;
    
    if(SL_S_IS_NIL(list))
        return SL_S_NIL;
    
    dest = &ret;
    do{
        *dest = SL_S_Malloc(sizeof(struct SL_S_List));
        (*dest)->ref = 1;
        (*dest)->head = cb(list->head, arg);
        dest = &((*dest)->tail);
    }while((list = list->tail) != SL_S_NIL);
    
    *dest = SL_S_NIL;
    return ret;
}

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

SL_S_FUNC(struct SL_S_Atom) *SL_S_IntToAtom(int n, unsigned short base){
    struct SL_S_Atom *atom;
    register int i;
    unsigned uarg;
    register int r;
    char *tail, *head;
    
    char buffer[40];
    i = 2;
    atom = SL_S_Malloc(sizeof(struct SL_S_Atom));
    atom->text = SL_S_Malloc(sizeof(buffer));
    atom->ref = 1;
    
    if(n == 0){
        atom->text[0] = '0';
        atom->text[1] = '\0';
        atom->len = 1;
        return atom;
    }
    
    head = atom->text;

    if (36 < base || 2 > base)
        base = 10; /* can only use 0-9, A-Z */
    
    tail = buffer + sizeof(buffer) - 1; /* last character position      */
    *tail-- = '\0';

    if(n < 0){
        *head++ = '-';
        uarg = -n;
    }
    else{
        uarg = n;
    }
    
    for (i = 1; uarg; ++i){
        r = uarg % base;
        *tail-- = (char)(r + ((9 < r) ? ('A' - 10) : '0'));
        uarg /= base;
    }
    
    SL_S_MemCopy(head, ++tail, i);
    atom->len = i;
    return atom;
}

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

SL_S_FUNC(int) SL_S_Compare(const void *a, const void *b){
    /* Handle nil's */
    union {
        void *ptr;
        int i;
        struct SL_S_Atom *atom;
        struct SL_S_List *list;
#ifdef SL_S_ENABLE_POINTERS
        struct SL_S_Pointer *pointer;
#endif
    } a_val, b_val;
    int a_tag, b_tag, r;
    
    if(a == b)
        return 0;
    
    if(SL_S_IS_NIL(a))
        return -1;
    if(SL_S_IS_NIL(b))
        return 1;
    
    SL_S_PTR_TAG_DATA(a, a_val.ptr, a_tag);
    SL_S_PTR_TAG_DATA(b, b_val.ptr, b_tag);
    
    if(a_tag != b_tag)
        return a_tag - b_tag;
    
    if(a_tag == SL_S_ATOM_TAG){
        r = (int)(a_val.atom->len) - (int)(b_val.atom->len);
        if(r != 0)
            return r;
        else if(a_val.atom->text == b_val.atom->text)
            return 0;
        else
            return SL_S_MemComp(a_val.atom->text,
                b_val.atom->text,
                a_val.atom->len);
    }
#ifdef SL_S_ENABLE_POINTERS
    if(a_tag == SL_S_POINTER_TAG){
        if(a_val.ptr == b_val.ptr ||
            a_val.pointer->data == b_val.pointer->data){
            
            return 0;
        }
        /* We can take a little shorcut when ints and ptrs are comparable. */
        if(sizeof(void*) <= sizeof(int)){
            a_val.ptr = a_val.pointer->data;
            b_val.ptr = a_val.pointer->data;
            return a_val.i - b_val.i;
        }

        if((char*)(a_val.pointer->data) - (char*)SL_S_NIL >
            (char*)(b_val.pointer->data) - (char*)SL_S_NIL){
            
            return 1;
        }
        else{
            return -1;
        }
    }
#endif
#ifdef SL_S_ENABLE_PROTOCOLS
    if(a_tag == SL_S_PROTOCOL_TAG){
        if(a_val.ptr == b_val.ptr)
            return 0;
        
        /* We can take a little shorcut when ints and ptrs are comparable. */
        if(sizeof(void*) <= sizeof(int))
            return a_val.i - b_val.i;

        if((char*)(a_val.ptr) - (char*)SL_S_NIL >
            (char*)(b_val.ptr) - (char*)SL_S_NIL){
            
            return 1;
        }
        else{
            return -1;
        }
    }
#endif
    
compare_list_again:
    r = SL_S_Compare(a_val.list->head, b_val.list->head);
    if(r != 0)
        return r;

    a_val.list = a_val.list->tail;
    b_val.list = b_val.list->tail;

    if(SL_S_IS_NIL(a_val.list) && SL_S_IS_NIL(b_val.list))
        return 0;
    else if(SL_S_IS_NIL(a_val.list))
        return -1;
    else if(SL_S_IS_NIL(b_val.list))
        return 1;
    goto compare_list_again;
}

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

SL_S_FUNC(int) SL_S_Match(const struct SL_S_List *in,
    const void **in_out_values,
    const unsigned char *flags,
    sl_s_len_t val_min,
    sl_s_len_t val_max){
    
    sl_s_len_t i;
    i = 0;
    while(!SL_S_IS_NIL(in)){
        /* Check if we are past the end. */
        if(i >= val_max)
            return -(int)(SL_S_Length(in) + i);
        
        /* Compare against the flags, if applicable */
        if((flags[i] & SL_S_IGNORE) == SL_S_IGNORE){
            goto next;
        }
        else if((flags[i] & SL_S_TEST_NIL_MASK) == SL_S_TEST_NIL){
            if(!SL_S_IS_NIL(in->head))
                return -(int)i;
        }
        else if((flags[i] & SL_S_ANY_MASK) == SL_S_ANY){
            /* Is an any. */
        }
        else if(SL_S_PTR_TAG(in->head, SL_S_NUM_TAG_BITS) !=
            (flags[i] & SL_S_PTR_TAG_MASK(SL_S_NUM_TAG_BITS))){
            
            return -1;
        }
        
        if((flags[i] & SL_S_IN_OUT_MASK) == SL_S_IN){
            /* Compare... */
            if(SL_S_Compare(in->head, in_out_values[i]) != 0)
                return -(int)i;
        }
        else{
            in_out_values[i] = in->head;
        }
next:
        in = in->tail;
        i++;
    }
    if(i < val_min)
        return -(int)i;
    else
        return i;
}

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