Source

duhton / glob.c

#include "duhton.h"


DuObject *Du_Progn(DuObject *cons, DuObject *locals)
{
    DuObject *result = Du_None;
    Du_INCREF(Du_None);
    while (cons != Du_None) {
        DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
        Du_DECREF(result);
        result = obj;
        cons = _DuCons_NEXT(cons);
    }
    return result;
}

DuObject *du_setq(DuObject *cons, DuObject *locals)
{
    DuObject *result = Du_None;
    Du_INCREF(Du_None);
    while (cons != Du_None) {
        DuObject *symbol = _DuCons_CAR(cons);
        cons = _DuCons_NEXT(cons);
        if (cons == Du_None)
            Du_FatalError("setq: number of arguments is odd");
        DuObject *expr = _DuCons_CAR(cons);
        DuObject *obj = Du_Eval(expr, locals);
        DuFrame_SetSymbol(locals, symbol, obj);
        Du_DECREF(result);
        result = obj;
        cons = _DuCons_NEXT(cons);
    }
    return result;
}

DuObject *du_print(DuObject *cons, DuObject *locals)
{
    int space = 0;
    while (cons != Du_None) {
        DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
        if (space) printf(" ");
        space = 1;
        Du_Print(obj, 0);
        Du_DECREF(obj);
        cons = _DuCons_NEXT(cons);
    }
    printf("\n");
    Du_INCREF(Du_None);
    return Du_None;
}

DuObject *du_add(DuObject *cons, DuObject *locals)
{
    int result = 0;
    while (cons != Du_None) {
        DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
        result += DuInt_AsInt(obj);
        Du_DECREF(obj);
        cons = _DuCons_NEXT(cons);
    }
    return DuInt_FromInt(result);
}

DuObject *du_sub(DuObject *cons, DuObject *locals)
{
    int result = 0;
    int sign = 1;
    while (cons != Du_None) {
        DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
        result += sign * DuInt_AsInt(obj);
        sign = -1;
        Du_DECREF(obj);
        cons = _DuCons_NEXT(cons);
    }
    return DuInt_FromInt(result);
}

DuObject *du_mul(DuObject *cons, DuObject *locals)
{
    int result = 1;
    while (cons != Du_None) {
        DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
        result *= DuInt_AsInt(obj);
        Du_DECREF(obj);
        cons = _DuCons_NEXT(cons);
    }
    return DuInt_FromInt(result);
}

DuObject *du_div(DuObject *cons, DuObject *locals)
{
    int result = 0;
    int first = 1;

    while (cons != Du_None) {
        DuObject *expr = _DuCons_CAR(cons);
        DuObject *next = _DuCons_NEXT(cons);

        DuObject *obj = Du_Eval(expr, locals);
        if (first) {
            result = DuInt_AsInt(obj);
            first = 0;
        } else {
            result /= DuInt_AsInt(obj);
        }
        Du_DECREF(obj);
        cons = next;
    }
    return DuInt_FromInt(result);
}

static DuObject *_du_intcmp(DuObject *cons, DuObject *locals, int mode)
{
    if (cons == Du_None || _DuCons_NEXT(cons) == Du_None ||
        _DuCons_NEXT(_DuCons_NEXT(cons)) != Du_None)
        Du_FatalError("get: expected two arguments");
    DuObject *obj_a = Du_Eval(_DuCons_CAR(cons), locals);
    DuObject *obj_b = Du_Eval(_DuCons_CAR(_DuCons_NEXT(cons)), locals);
    int a = DuInt_AsInt(obj_a);
    int b = DuInt_AsInt(obj_b);
    Du_DECREF(obj_a);
    Du_DECREF(obj_b);
    int r = 0;
    switch (mode) {
    case 0: r = a < b; break;
    case 1: r = a <= b; break;
    case 2: r = a == b; break;
    case 3: r = a != b; break;
    case 4: r = a > b; break;
    case 5: r = a >= b; break;
    }
    return DuInt_FromInt(r);
}

DuObject *du_lt(DuObject *cons, DuObject *locals)
{ return _du_intcmp(cons, locals, 0); }
DuObject *du_le(DuObject *cons, DuObject *locals)
{ return _du_intcmp(cons, locals, 1); }
DuObject *du_eq(DuObject *cons, DuObject *locals)
{ return _du_intcmp(cons, locals, 2); }
DuObject *du_ne(DuObject *cons, DuObject *locals)
{ return _du_intcmp(cons, locals, 3); }
DuObject *du_gt(DuObject *cons, DuObject *locals)
{ return _du_intcmp(cons, locals, 4); }
DuObject *du_ge(DuObject *cons, DuObject *locals)
{ return _du_intcmp(cons, locals, 5); }

DuObject *du_type(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None || _DuCons_NEXT(cons) != Du_None)
        Du_FatalError("type: expected one argument");
    DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
    DuObject *res = (DuObject *)(obj->ob_type);
    Du_INCREF(res);
    Du_DECREF(obj);
    return res;
}

DuObject *du_quote(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None || _DuCons_NEXT(cons) != Du_None)
        Du_FatalError("quote: expected one argument");
    DuObject *obj = _DuCons_CAR(cons);
    Du_INCREF(obj);
    return obj;
}

DuObject *du_list(DuObject *cons, DuObject *locals)
{
    DuObject *list = DuList_New();
    while (cons != Du_None) {
        DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
        DuList_Append(list, obj);
        Du_DECREF(obj);
        cons = _DuCons_NEXT(cons);
    }
    return list;
}

DuObject *du_get(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None || _DuCons_NEXT(cons) == Du_None ||
        _DuCons_NEXT(_DuCons_NEXT(cons)) != Du_None)
        Du_FatalError("get: expected two arguments");
    DuObject *lst = Du_Eval(_DuCons_CAR(cons), locals);
    DuObject *index = Du_Eval(_DuCons_CAR(_DuCons_NEXT(cons)), locals);
    DuObject *res = DuList_GetItem(lst, DuInt_AsInt(index));
    Du_DECREF(index);
    Du_DECREF(lst);
    return res;
}

DuObject *du_set(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None || _DuCons_NEXT(cons) == Du_None ||
        _DuCons_NEXT(_DuCons_NEXT(cons)) == Du_None ||
        _DuCons_NEXT(_DuCons_NEXT(_DuCons_NEXT(cons))) != Du_None)
        Du_FatalError("set: expected three arguments");
    DuObject *lst = Du_Eval(_DuCons_CAR(cons), locals);
    DuObject *index = Du_Eval(_DuCons_CAR(_DuCons_NEXT(cons)), locals);
    DuObject *newobj = Du_Eval(_DuCons_CAR(_DuCons_NEXT(_DuCons_NEXT(cons))),
                               locals);
    DuList_SetItem(lst, DuInt_AsInt(index), newobj);
    Du_DECREF(index);
    Du_DECREF(lst);
    return newobj;
}

DuObject *du_append(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None || _DuCons_NEXT(cons) == Du_None ||
        _DuCons_NEXT(_DuCons_NEXT(cons)) != Du_None)
        Du_FatalError("append: expected two arguments");
    DuObject *lst = Du_Eval(_DuCons_CAR(cons), locals);
    DuObject *newobj = Du_Eval(_DuCons_CAR(_DuCons_NEXT(cons)), locals);
    DuList_Append(lst, newobj);
    Du_DECREF(lst);
    return newobj;
}

DuObject *du_pop(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None || _DuCons_NEXT(cons) == Du_None ||
        _DuCons_NEXT(_DuCons_NEXT(cons)) != Du_None)
        Du_FatalError("pop: expected two arguments");
    DuObject *lst = Du_Eval(_DuCons_CAR(cons), locals);
    DuObject *index = Du_Eval(_DuCons_CAR(_DuCons_NEXT(cons)), locals);
    DuObject *res = DuList_Pop(lst, DuInt_AsInt(index));
    Du_DECREF(index);
    Du_DECREF(lst);
    return res;
}

DuObject *du_len(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None || _DuCons_NEXT(cons) != Du_None)
        Du_FatalError("len: expected one argument");
    DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
    int length = DuObject_Length(obj);
    Du_DECREF(obj);
    return DuInt_FromInt(length);
}

DuObject *du_if(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None || _DuCons_NEXT(cons) == Du_None)
        Du_FatalError("if: expected at least two arguments");
    DuObject *cond = Du_Eval(_DuCons_CAR(cons), locals);
    int cond_int = DuObject_IsTrue(cond);
    Du_DECREF(cond);
    if (cond_int != 0) {
        /* true path */
        return Du_Eval(_DuCons_CAR(_DuCons_NEXT(cons)), locals);
    }
    else {
        /* false path */
        return Du_Progn(_DuCons_NEXT(_DuCons_NEXT(cons)), locals);
    }
}

DuObject *du_while(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None)
        Du_FatalError("while: expected at least one argument");
    while (1) {
        DuObject *cond = Du_Eval(_DuCons_CAR(cons), locals);
        int cond_int = DuObject_IsTrue(cond);
        Du_DECREF(cond);
        if (cond_int == 0)
            break;
        DuObject *res = Du_Progn(_DuCons_NEXT(cons), locals);
        Du_DECREF(res);
    }
    Du_INCREF(Du_None);
    return Du_None;
}

DuObject *du_defun(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None || _DuCons_NEXT(cons) == Du_None)
        Du_FatalError("defun: expected at least two arguments");
    DuObject *name = _DuCons_CAR(cons);
    DuObject *arglist = _DuCons_CAR(_DuCons_NEXT(cons));
    DuObject *progn = _DuCons_NEXT(_DuCons_NEXT(cons));
    DuFrame_SetUserFunction(locals, name, arglist, progn);
    Du_INCREF(Du_None);
    return Du_None;
}

DuObject *du_car(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None || _DuCons_NEXT(cons) != Du_None)
        Du_FatalError("car: expected one argument");
    DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
    DuObject *res = DuCons_Car(obj);
    Du_DECREF(obj);
    return res;
}

DuObject *du_cdr(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None || _DuCons_NEXT(cons) != Du_None)
        Du_FatalError("car: expected one argument");
    DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
    DuObject *res = DuCons_Cdr(obj);
    Du_DECREF(obj);
    return res;
}

DuObject *du_not(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None || _DuCons_NEXT(cons) != Du_None)
        Du_FatalError("not: expected one argument");
    DuObject *obj = Du_Eval(_DuCons_CAR(cons), locals);
    int res = !DuObject_IsTrue(obj);
    Du_DECREF(obj);
    return DuInt_FromInt(res);
}

DuObject *du_transaction(DuObject *cons, DuObject *locals)
{
    if (cons == Du_None)
        Du_FatalError("transaction: expected at least one argument");
    DuObject *sym = _DuCons_CAR(cons);
    DuObject *rest = _DuCons_NEXT(cons);
    DuObject *frame = _DuFrame_EvalCall(locals, sym, rest, 0);
    Du_TransactionAdd(frame);
    Du_DECREF(frame);
    Du_INCREF(Du_None);
    return Du_None;
}


DuObject *Du_Globals;

void Du_Initialize(void)
{
#ifdef Du_DEBUG
    chainedlist.ob_debug_prev = &chainedlist;
    chainedlist.ob_debug_next = &chainedlist;
#endif

    Du_Globals = DuFrame_New(Du_None);
    DuFrame_SetBuiltinMacro(Du_Globals, "progn", Du_Progn);
    DuFrame_SetBuiltinMacro(Du_Globals, "setq", du_setq);
    DuFrame_SetBuiltinMacro(Du_Globals, "print", du_print);
    DuFrame_SetBuiltinMacro(Du_Globals, "+", du_add);
    DuFrame_SetBuiltinMacro(Du_Globals, "-", du_sub);
    DuFrame_SetBuiltinMacro(Du_Globals, "*", du_mul);
    DuFrame_SetBuiltinMacro(Du_Globals, "/", du_div);
    DuFrame_SetBuiltinMacro(Du_Globals, "<", du_lt);
    DuFrame_SetBuiltinMacro(Du_Globals, "<=", du_le);
    DuFrame_SetBuiltinMacro(Du_Globals, "==", du_eq);
    DuFrame_SetBuiltinMacro(Du_Globals, "!=", du_ne);
    DuFrame_SetBuiltinMacro(Du_Globals, ">", du_gt);
    DuFrame_SetBuiltinMacro(Du_Globals, ">=", du_ge);
    DuFrame_SetBuiltinMacro(Du_Globals, "type", du_type);
    DuFrame_SetBuiltinMacro(Du_Globals, "quote", du_quote);
    DuFrame_SetBuiltinMacro(Du_Globals, "list", du_list);
    DuFrame_SetBuiltinMacro(Du_Globals, "get", du_get);
    DuFrame_SetBuiltinMacro(Du_Globals, "set", du_set);
    DuFrame_SetBuiltinMacro(Du_Globals, "append", du_append);
    DuFrame_SetBuiltinMacro(Du_Globals, "pop", du_pop);
    DuFrame_SetBuiltinMacro(Du_Globals, "len", du_len);
    DuFrame_SetBuiltinMacro(Du_Globals, "if", du_if);
    DuFrame_SetBuiltinMacro(Du_Globals, "while", du_while);
    DuFrame_SetBuiltinMacro(Du_Globals, "defun", du_defun);
    DuFrame_SetBuiltinMacro(Du_Globals, "car", du_car);
    DuFrame_SetBuiltinMacro(Du_Globals, "cdr", du_cdr);
    DuFrame_SetBuiltinMacro(Du_Globals, "not", du_not);
    DuFrame_SetBuiltinMacro(Du_Globals, "transaction", du_transaction);
    DuFrame_SetSymbolStr(Du_Globals, "None", Du_None);
}

void Du_Finalize(void)
{
    Du_DECREF(Du_Globals);
    Du_Globals = NULL;

#ifdef Du_DEBUG
    DuObject *obj;
    for (obj = chainedlist.ob_debug_next;
         obj != &chainedlist;
         obj = obj->ob_debug_next) {
        printf("NOT FREED: ");
        Du_Print(obj, 1);
    }
    chainedlist.ob_debug_prev = NULL;
    chainedlist.ob_debug_next = NULL;
#endif
}