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_i_builtin.h"

#include "sl_i.h"
#include "sl_x.h"

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

const struct SL_S_Atom sl_i_print_name = SL_S_STATIC_ATOM("print");

SL_S_FUNC(void) *SL_I_Print(struct SL_I_Runtime *rt,
    const struct SL_S_List *args){
    
    struct SL_S_Atom *atom;
    struct SL_S_List *list;
    if(SL_S_IS_NIL(args->head)){
        rt->io.write(rt->io.x_stdout, "nil", 3);
    }
    if(SL_S_IS_LIST(args->head)){
        rt->io.write(rt->io.x_stdout, "( ", 2);
        for(list = SL_S_PTR_FROM_TAG(args->head);
            list != SL_S_NIL;
            list = list->tail){
            
            SL_I_Print(rt, list);
            rt->io.write(rt->io.x_stdout, " ", 1);
        }
        rt->io.write(rt->io.x_stdout, ")", 1);
    }
    else{
        atom = SL_S_PTR_FROM_TAG(args->head);
        rt->io.write(rt->io.x_stdout, atom->text, atom->len);
    }
    return SL_S_NIL;
}

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

const struct SL_S_Atom sl_i_atom_length_name = SL_S_STATIC_ATOM("atom-length");

SL_S_FUNC(void) *SL_I_AtomLength(struct SL_I_Runtime *rt,
    const struct SL_S_List *args){
    
    sl_s_len_t len;
    
    if(SL_S_IS_NIL(args))
        return SL_S_MK_ATOM(sl_x_integers + 3);
    
    if(!SL_S_IS_ATOM(args->head)){
        rt->pending_error = "Argument to atom-length must be an atom";
        return SL_S_NIL;
    }
    
    len = ((struct SL_S_Atom*)SL_S_PTR_FROM_TAG(args->head))->len;
    if(len < SL_X_N_INTEGERS)
        return SL_S_MK_ATOM(sl_x_integers + len);
    else
        return SL_S_MK_ATOM(SL_S_IntToAtom(len, 10));
}

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

const struct SL_S_Atom sl_i_open_name = SL_S_STATIC_ATOM("open");

SL_S_FUNC(void) *SL_I_Open(struct SL_I_Runtime *rt,
    const struct SL_S_List *args){
    
    void *file;
    struct SL_S_Pointer *ptr;
    struct SL_S_Atom *path, *mode;
    if(!(SL_S_IS_ATOM(args->head) &&
        (args->tail == SL_S_NIL ? 1 : SL_S_IS_ATOM(args->tail->head)))){
        
        rt->pending_error = "Type error for open";
        return SL_S_NIL;
    }
    
    path = SL_S_PTR_FROM_TAG(args->head);
    if(SL_S_IS_NIL(args->tail)){
        file = rt->io.open_read(path->text);
    }
    else{
        mode = SL_S_PTR_FROM_TAG(args->tail->head);
        if(SL_S_COMPARE_ATOMS(mode, &sl_x_false)){
            file = rt->io.open_read(path->text);
        }
        else if(SL_S_COMPARE_ATOMS(mode, &sl_x_true)){
            file = rt->io.open_write(path->text);
        }
        else{
            rt->pending_error = "Arg 2 to open must be true or false.";
            return SL_S_NIL;
        }
    }
    if(SL_S_IS_NIL(file))
        return SL_S_NIL;
    
    ptr = SL_S_Malloc(sizeof(struct SL_S_Pointer));
    ptr->ref = 1;
#ifndef SL_S_NO_PARSER_INFO
    ptr->line = 0;
#endif
    ptr->data = file;
    return SL_S_MK_PTR(ptr);
}

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

const struct SL_S_Atom sl_i_close_name = SL_S_STATIC_ATOM("close");

SL_S_FUNC(void) *SL_I_Close(struct SL_I_Runtime *rt,
    const struct SL_S_List *args){
    
    struct SL_S_Pointer *ptr;
    if(SL_S_IS_NIL(args->head))
        return SL_S_NIL;

    if(!SL_S_IS_PTR(args->head)){
        rt->pending_error = "Type error in close";
        return SL_S_NIL;
    }
    
    ptr = SL_S_PTR_FROM_TAG(args->head);
    rt->io.close(ptr->data);
    return SL_S_NIL;
}

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

const struct SL_S_Atom sl_i_read_name = SL_S_STATIC_ATOM("read");

SL_S_FUNC(void) *SL_I_Read(struct SL_I_Runtime *rt,
    const struct SL_S_List *args){

    struct SL_S_Pointer *ptr, *ret_ptr;
    struct SL_S_List *ret;
    struct SL_S_Atom *n_str;
    int n, r;
    
    if(SL_S_IS_NIL(args->tail) || !SL_S_IS_ATOM(args->tail->head)){
        rt->pending_error = "Type error in read";
        return SL_S_NIL;
    }
    
    n_str = SL_S_PTR_FROM_TAG(args->tail->head);
    if(SL_X_TryParseInt(n_str, &n) != 0 || n < 0){
        rt->pending_error = "Arg 2 to read must be a positive integer";
        return SL_S_NIL;
    }

    if(SL_S_IS_NIL(args->head))
        return SL_S_NIL;

    if(!SL_S_IS_PTR(args->head)){
        rt->pending_error = "Type error in read";
        return SL_S_NIL;
    }
    
    ptr = SL_S_PTR_FROM_TAG(args->head);
    
    
    ret_ptr = SL_S_Malloc(sizeof(struct SL_S_Pointer));
    ret_ptr->ref = 1;
#ifndef SL_S_NO_PARSER_INFO
    ret_ptr->line = 0;
#endif
    ret_ptr->data = SL_S_Malloc(n);
    
    r = rt->io.read(ptr->data, ret_ptr->data, n);
    
    ret = SL_S_Malloc(sizeof(struct SL_S_List));
    ret->tail = SL_S_Malloc(sizeof(struct SL_S_List));
    ret->ref = 1;
    ret->tail->ref = 1;
#ifndef SL_S_NO_PARSER_INFO
    ret->line = 0;
    ret->tail->line = 0;
#endif
    ret->tail->tail = SL_S_NIL;
    ret->head = ret_ptr;
    if(r == n){
        SL_S_INCREF(n_str);
        ret->tail->head = SL_S_MK_ATOM(n_str);
    }
    else if(r >= 0 && r < SL_X_N_INTEGERS){
        ret->tail->head = SL_S_MK_ATOM(sl_x_integers + r);
    }
    else{
        ret->tail->head = SL_S_MK_ATOM(SL_S_IntToAtom(r, 10));
    }
    return ret;
}

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

const struct SL_S_Atom sl_i_write_name = SL_S_STATIC_ATOM("write");

#define SL_I_WRITE_ARITY 3
static const unsigned char sl_i_write_flags[SL_I_WRITE_ARITY] = {
    SL_S_OUT|SL_S_POINTER_TAG,
    SL_S_OUT|SL_S_POINTER_TAG,
    SL_S_OUT|SL_S_ATOM_TAG
};

SL_S_FUNC(void) *SL_I_Write(struct SL_I_Runtime *rt,
    const struct SL_S_List *args){
    
    const void *matched_args[SL_I_WRITE_ARITY];
    const struct SL_S_Pointer *file, *data;
    const struct SL_S_Atom *n_str;
    int n, r;

    if(SL_S_Match(args,
        matched_args,
        sl_i_write_flags,
        SL_I_WRITE_ARITY,
        SL_I_WRITE_ARITY) != SL_I_WRITE_ARITY){
        
        rt->pending_error = "Args error in write";
        return SL_S_NIL;
    }
    
    file = SL_S_PTR_FROM_TAG(matched_args[0]);
    data = SL_S_PTR_FROM_TAG(matched_args[1]);
    n_str = SL_S_PTR_FROM_TAG(matched_args[2]);
    
    if(SL_X_TryParseInt(n_str, &n) != 0 || n < 0){
        rt->pending_error = "Arg 2 to write must be a positive integer";
        return SL_S_NIL;
    }
    
    r = rt->io.write(file->data, data->data, n);
    if(r == n){
        SL_S_INCREF(n_str);
        return SL_S_MK_ATOM(n_str);
    }
    else if(r >= 0 && r < SL_X_N_INTEGERS){
        return SL_S_MK_ATOM(sl_x_integers + r);
    }
    else{
        return SL_S_MK_ATOM(SL_S_IntToAtom(r, 10));
    }
}

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

const struct SL_S_Atom sl_i_write_atom_name = SL_S_STATIC_ATOM("write-atom");
#define SL_I_WRITE_ATOM_ARITY 2

SL_S_FUNC(void) *SL_I_WriteAtom(struct SL_I_Runtime *rt,
    const struct SL_S_List *args){
    
    const void *matched_args[SL_I_WRITE_ATOM_ARITY];
    const struct SL_S_Pointer *file;
    const struct SL_S_Atom *data;
    int r;
    
    /* Little hack, we can re-use the write flags. */
    if(SL_S_Match(args,
        matched_args,
        sl_i_write_flags + 1,
        SL_I_WRITE_ATOM_ARITY,
        SL_I_WRITE_ATOM_ARITY) != SL_I_WRITE_ATOM_ARITY){
        
        rt->pending_error = "Args error in write-atom";
        return SL_S_NIL;
    }
    
    file = SL_S_PTR_FROM_TAG(matched_args[0]);
    data = SL_S_PTR_FROM_TAG(matched_args[1]);
    
    r = rt->io.write(file->data, data->text, data->len);
    if(r >= 0 && r < SL_X_N_INTEGERS){
        return SL_S_MK_ATOM(sl_x_integers + r);
    }
    else{
        return SL_S_MK_ATOM(SL_S_IntToAtom(r, 10));
    }
}