quakeforge/ruamoko/scheme/builtins.r

#include "Void.h"
#include "Nil.h"
#include "Number.h"
#include "builtins.h"
#include "defs.h"
#include "string.h"
#include "Cons.h"
#include "Continuation.h"
#include "BaseContinuation.h"
#include "Boolean.h"
#include "Error.h"

BOOL num_args (SchemeObject list, integer num)
{
    for (; [list isKindOfClass: [Cons class]]; list = [(Cons) list cdr]) {
            num--;
    }
    return num == 0;
}

SchemeObject bi_display (SchemeObject args, Machine m)
{
    if (!num_args(args, 1)) {
            return [Error type: "display"
                          message: "expected 1 argument"
                          by: m];
    }
    print([[(Cons) args car] printForm]);
    return [Void voidConstant];
}

SchemeObject bi_newline (SchemeObject args, Machine m)
{
    if (!num_args(args, 0)) {
            return [Error type: "newline"
                          message: "expected no arguments"
                          by: m];
    }
    print("\n");
    return [Void voidConstant];
}

SchemeObject bi_add (SchemeObject args, Machine m)
{
    local integer sum = 0;
    local SchemeObject cur;

    for (cur = args; cur != [Nil nil]; cur = [(Cons) cur cdr]) {
            if (![[(Cons) cur car] isKindOfClass: [Number class]]) {
                    return [Error type: "+"
                                  message: sprintf("non-number argument: %s\n",
                                                   [[(Cons) cur car] printForm])
                                  by: m];
            }                     
            sum += [(Number) [(Cons) cur car] intValue];
    }

    return [Number newFromInt: sum];
}

SchemeObject bi_sub (SchemeObject args, Machine m)
{
    local integer diff = 0;
    local SchemeObject cur;

    if (args == [Nil nil]) {
            return [Error type: "-"
                          message: sprintf("expected at least 1 argument")
                          by: m];
    }

    cur = [(Cons) args car];
    
    if (![cur isKindOfClass: [Number class]]) {
            return [Error type: "-"
                          message: sprintf("non-number argument: %s\n",
                                           [cur printForm])
                          by: m];
    }

    diff = [(Number) cur intValue];
    
    if ([(Cons) args cdr] == [Nil nil]) {
            return [Number newFromInt: -diff];
    }
    
    for (cur = [(Cons) args cdr]; cur != [Nil nil]; cur = [(Cons) cur cdr]) {
            if (![[(Cons) cur car] isKindOfClass: [Number class]]) {
                    return [Error type: "-"
                                  message: sprintf("non-number argument: %s\n",
                                                   [[(Cons) cur car] printForm])
                                  by: m];
            }                     
            diff -= [(Number) [(Cons) cur car] intValue];
    }

    return [Number newFromInt: diff];
}

SchemeObject bi_mult (SchemeObject args, Machine m)
{
    local integer prod = 1;
    local SchemeObject cur;

    for (cur = args; cur != [Nil nil]; cur = [(Cons) cur cdr]) {
            if (![[(Cons) cur car] isKindOfClass: [Number class]]) {
                    return [Error type: "*"
                                  message: sprintf("non-number argument: %s\n",
                                                   [[(Cons) cur car] printForm])
                                  by: m];
            }                     
            prod *= [(Number) [(Cons) cur car] intValue];
    }

    return [Number newFromInt: prod];
}

SchemeObject bi_div (SchemeObject args, Machine m)
{
    local integer frac = 0;
    local SchemeObject cur;

    if (args == [Nil nil]) {
            return [Error type: "/"
                          message: sprintf("expected at least 1 argument")
                          by: m];
    }

    cur = [(Cons) args car];
    
    if (![cur isKindOfClass: [Number class]]) {
            return [Error type: "/"
                          message: sprintf("non-number argument: %s\n",
                                           [cur printForm])
                          by: m];
    }

    frac = [(Number) cur intValue];
    
    if ([(Cons) args cdr] == [Nil nil]) {
            return [Number newFromInt: 1/frac];
    }
    
    for (cur = [(Cons) args cdr]; cur != [Nil nil]; cur = [(Cons) cur cdr]) {
            if (![[(Cons) cur car] isKindOfClass: [Number class]]) {
                    return [Error type: "/"
                                  message: sprintf("non-number argument: %s\n",
                                                   [[(Cons) cur car] printForm])
                                  by: m];
            }                     
            frac /= [(Number) [(Cons) cur car] intValue];
    }

    return [Number newFromInt: frac];
}

SchemeObject bi_cons (SchemeObject args, Machine m)
{
    if (!num_args(args, 2)) {
            return [Error type: "cons"
                          message: "expected 2 arguments"
                          by: m];
    }
    [(Cons) args cdr: [(Cons) [(Cons) args cdr] car]];
    return args;
}

SchemeObject bi_null (SchemeObject args, Machine m)
{
    if (!num_args(args, 1)) {
            return [Error type: "null?"
                          message: "expected 1 argument"
                          by: m];
    }
    return [(Cons) args car] == [Nil nil]
        ?
        [Boolean trueConstant] :
        [Boolean falseConstant];
}

SchemeObject bi_car (SchemeObject args, Machine m)
{
    if (!num_args(args, 1)) {
            return [Error type: "car"
                          message: "expected 1 argument"
                          by: m];
    }
    if (![[(Cons) args car] isKindOfClass: [Cons class]]) {
            return [Error type: "car"
                          message: sprintf("expected pair, got: %s",
                                           [[(Cons) args car] printForm])
                          by: m];
    }
                
    return [(Cons) [(Cons) args car] car];
}

SchemeObject bi_cdr (SchemeObject args, Machine m)
{
    if (!num_args(args, 1)) {
            return [Error type: "cdr"
                          message: "expected 1 argument"
                          by: m];
    }
    if (![[(Cons) args car] isKindOfClass: [Cons class]]) {
            return [Error type: "cdr"
                          message: sprintf("expected pair, got: %s",
                                           [[(Cons) args car] printForm])
                          by: m];
    }
    return [(Cons) [(Cons) args car] cdr];
}

SchemeObject bi_apply (SchemeObject args, Machine m)
{
    local SchemeObject cur, prev;
    if (args == [Nil nil]) {
            return [Error type: "apply"
                          message: "expected at least 1 argument"
                          by: m];
    } else if (![[(Cons) args car] isKindOfClass: [Procedure class]]) {
            return [Error type: "apply"
                          message:
                              sprintf("expected procedure as 1st argument, got: %s",
                                      [[(Cons) args car] printForm])
                          by: m];
    }

    prev = NIL;
    
    for (cur = args; [(Cons) cur cdr] != [Nil nil]; cur = [(Cons) cur cdr]) {
            prev = cur;
    }

    if (prev) {
            [(Cons) prev cdr: [(Cons) cur car]];
    }
    
    [m stack: [(Cons) args cdr]];
    [(Procedure) [(Cons) args car] invokeOnMachine: m];
    return NIL;
}

SchemeObject bi_callcc (SchemeObject args, Machine m)
{
    if (args == [Nil nil]) {
            return [Error type: "call-with-current-continuation"
                          message: "expected at least 1 argument"
                          by: m];
    } else if (![[(Cons) args car] isKindOfClass: [Procedure class]]) {
            return [Error type: "call-with-current-continuation"
                          message:
                              sprintf("expected procedure as 1st argument, got: %s",
                                      [[(Cons) args car] printForm])
                          by: m];
    }
    if ([m continuation]) {
            [m stack: cons([m continuation], [Nil nil])];
    } else {
            [m stack: cons([BaseContinuation baseContinuation],
                           [Nil nil])];
    }
    [(Procedure) [(Cons) args car] invokeOnMachine: m];
    return NIL;
}

SchemeObject bi_eq (SchemeObject args, Machine m)
{
    if (!num_args(args, 2)) {
            return [Error type: "eq?"
                          message: "expected 2 arguments"
                          by: m];
    }
    return
        [(Cons) args car] == [(Cons) [(Cons) args cdr] car] ?
        [Boolean trueConstant] :
        [Boolean falseConstant];
}

SchemeObject bi_numeq (SchemeObject args, Machine m)
{
    local SchemeObject num1, num2;
    if (!num_args(args, 2)) {
            return [Error type: "="
                          message: "expected 2 arguments"
                          by: m];
    }
    num1 = [(Cons) args car];
    num2 = [(Cons) [(Cons) args cdr] car];
    if (![num1 isKindOfClass: [Number class]]) {
            return [Error type: "="
                          message: sprintf("expected number argument, got: %s",
                                           [num1 printForm])
                          by: m];
    } else if (![num2 isKindOfClass: [Number class]]) {
            return [Error type: "="
                          message: sprintf("expected number argument, got: %s",
                                           [num2 printForm])
                          by: m];
    }

    return
        [(Number) num1 intValue] == [(Number) num2 intValue] ?
        [Boolean trueConstant] :
        [Boolean falseConstant];
}

SchemeObject bi_islist (SchemeObject args, Machine m)
{
    if (!num_args(args, 1)) {
            return [Error type: "list?"
                          message: "expected 1 argument"
                          by: m];
    }

    return
        isList (args) ?
        [Boolean trueConstant] :
        [Boolean falseConstant];
}

SchemeObject bi_ispair (SchemeObject args, Machine m)
{
    if (!num_args(args, 1)) {
            return [Error type: "pair?"
                          message: "expected 1 argument"
                          by: m];
    }

    return
        [[(Cons) args car] isKindOfClass: [Cons class]] ?
        [Boolean trueConstant] :
        [Boolean falseConstant];
}

#define builtin(name, func) [m addGlobal: symbol(#name) value: [Primitive newFromFunc: (func)]]

void builtin_addtomachine (Machine m)
{
    builtin(display, bi_display);
    builtin(newline, bi_newline);
    builtin(+, bi_add);
    builtin(-, bi_sub);
    builtin(*, bi_mult);
    builtin(/, bi_div);
    builtin(cons, bi_cons);
    builtin(null?, bi_null);
    builtin(car, bi_car);
    builtin(cdr, bi_cdr);
    builtin(apply, bi_apply);
    builtin(call-with-current-continuation, bi_callcc);
    builtin(eq?, bi_eq);
    builtin(=, bi_numeq);
    builtin(list?, bi_islist);
    builtin(pair?, bi_ispair);
}