11
\$\begingroup\$

I created a basic Scheme interpreter in C

#include <stdio.h>
#include <string.h>
#include <stdint.h>
#include <stdlib.h>
#include <stdbool.h>
#include <ctype.h>

#define BT_FREE 0
#define BT_READY 1
#define BT_ATOM 2
#define BT_NUM 3
#define BT_CONS 4
#define BT_FUNCTION 5
#define BT_FORM 6
#define BT_BUILTIN 7
#define BT_DYNAMIC 8

#define TOK_NIL 0
#define TOK_ERROR 1
#define TOK_OPEN 2
#define TOK_CLOSE 3
#define TOK_QUOTE 4
#define TOK_DOT 5

typedef struct {
    int type;
    union {
    struct {
        int car;
        int cdr;
    };
    int64_t id;
    };
} cons_cell;

int hptr = 10;

#define TABLE_SIZE 999983
cons_cell cons_cells[TABLE_SIZE];
const char *atom_table[TABLE_SIZE];

/**
 * Returns the 'car' (first element) of a cons cell identified by its ID.
 *
 * @param id The ID of the cons cell.
 * @return The 'car' of the cons cell.
 */
int car(int id)
{
    return cons_cells[id].car;
}

/**
 * Returns the 'cdr' (rest) of a cons cell identified by its ID.
 *
 * @param id The ID of the cons cell.
 * @return The 'cdr' of the cons cell.
 */
int cdr(int id)
{
    return cons_cells[id].cdr;
}

/**
 * Returns the 'car' (first element) of the 'cdr' (rest) of a cons cell
 * identified by its ID.
 *
 * @param id The ID of the cons cell.
 * @return The 'car' of the 'cdr'.
 */
int cadr(int id)
{
    return car(cdr(id));
}

/**
 * Returns the 'car' (first element) of the 'cdr' (rest) of a cons cell
 * identified by its ID.
 *
 * @param id The ID of the cons cell.
 * @return The 'car' of the 'cdr'.
 */
int cddr(int id)
{
    return cdr(cdr(id));
}

/**
 * Returns the 'car' (first element) of the 'cdr' (rest) of the 'cdr' (rest) of
 * a cons cell identified by its ID.
 *
 * @param id The ID of the cons cell.
 * @return The 'car' of the 'cdr' of the 'cdr'.
 */
int caddr(int id)
{
    return car(cdr(cdr(id)));
}

int cdddr(int id)
{
    return cdr(cdr(cdr(id)));
}

/**
 * Returns the 'car' (first element) of the 'cdr' (rest) of the 'cdr' (rest) of
 * the 'cdr' (rest) of a cons cell identified by its ID.
 *
 * @param id The ID of the cons cell.
 * @return The 'car' of the 'cdr' of the 'cdr' of the 'cdr'.
 */
int cadddr(int id)
{
    return car(cdr(cdr(cdr(id))));
}

/**
 * Allocates a new memory cell and returns its identifier.
 *
 * @return The identifier of the newly allocated memory cell.
 */
int alloc()
{
    return hptr++;
}

/**
 * Allocates a new cons cell with the specified car and cdr values.
 *
 * @param car The identifier of the car value.
 * @param cdr The identifier of the cdr value.
 * @return The identifier of the newly allocated cons cell.
 */
int alloc_cons(int car, int cdr)
{
    int p = alloc();
    cons_cells[p].type = BT_CONS;
    cons_cells[p].car = car;
    cons_cells[p].cdr = cdr; 
    return p;
}

#define show_error(...) do { fprintf(stderr, __VA_ARGS__); exit(0); } while(0)
#define show_warning(...) fprintf(stderr, __VA_ARGS__)

/**
 * Calculates a hash value for a given string.
 *
 * @param s The string for which to calculate the hash value.
 * @return The calculated hash value.
 */
int hash_function(const char *s)
{
    int hashValue = 0;
    for (const char *c=s; *c; c++) {
    hashValue = (hashValue * 31 + tolower(*c)) % TABLE_SIZE;
    }
    return hashValue;
}

bool iequals(const char *a, const char *b) {
  return !strcmp(a,b);
}


/**
 * Interns a string into the atom table and returns its hash value.
 *
 * @param s The string to be interned.
 * @return The hash value of the interned string.
 */
int intern(const char* s)
{
    int hash_value = hash_function(s);
    int original_hash = hash_value;
    int i = 1;

    while (atom_table[hash_value] &&
       !iequals(atom_table[hash_value], s)) {
    hash_value = (original_hash + i) % TABLE_SIZE;
    i++;
    }

    atom_table[hash_value] = s;
    return hash_value;
}

/**
 * Converts a string to an atom or number and returns its identifier.
 *
 * @param s The string to be converted.
 * @return The identifier of the resulting atom or number.
 */
int string_to_atom(const char *s) {
    if (iequals(s, "nil")) {
        return TOK_NIL;
    }
    
    size_t n = strlen(s);
    size_t y = 0;
    int64_t nval = 0;
    
    // Check if the string represents a number
    if ((s[0] == '-' && isdigit(s[1])) || isdigit(s[0])) {
        char *endptr;
        nval = strtoll(s, &endptr, 0);
        y = endptr - s;
    }
    
    int x = alloc();
    
    if (y == n) {
        cons_cells[x].type = BT_NUM;
        cons_cells[x].id = nval;
    } else {
        int pt = intern(s);
        cons_cells[x].type = BT_ATOM;
        cons_cells[x].id = pt;
    }
    
    return x;
}

int atom_quote;
int atom_true;

void append_char(char **str, size_t *len, size_t *cap, char ch) {
        if (*len + 1 >= *cap) {
            *cap = (*cap == 0) ? 1 : (*cap * 2);
            *str = realloc(*str, *cap);
            if (*str == NULL) {
                perror("Failed to allocate memory");
                exit(EXIT_FAILURE);
            }
        }
        (*str)[(*len)++] = ch;
        (*str)[*len] = '\0';
}

/**
 * Reads and returns the next token from the input stream, handling various
 * cases including escape commands, comments, parentheses, and symbols.
 *
 * @return The token identifier for the read token. Possible values include:
 *         - TOK_OPEN: Opening parenthesis '('.
 *         - TOK_CLOSE: Closing parenthesis ')'.
 *         - TOK_DOT: Dot '.' indicating a pair.
 *         - TOK_QUOTE: Single quote '\'' indicating a quoted expression.
 *         - TOK_ERROR: An error occurred during token reading.
 *         - id for atom for an identifier or number
 */
int read_token()
{
    int c;
    for (;;) {
    c = getchar();
    while (isspace(c))
        c = getchar();
    if (c == ':') {     /* escape commands */
        c = getchar();
        if (c == 'q')
        exit(0);
        else
        return TOK_ERROR;
        while ((c = getchar()) != '\n');
    } else if (c == ';') {  /* end of line comment */
        while ((c = getchar()) != '\n');
    }
    if (c == EOF)
        exit(0);
    switch (c) {
    case '(':
        return TOK_OPEN;
    case ')':
        return TOK_CLOSE;
    case '.':
        return TOK_DOT;
    case '\'':
        return TOK_QUOTE;
    default:
      char *s = NULL;
      size_t length = 0, capacity = 0;
      append_char(&s, &length, &capacity, c);
      
      for (;;) {
        c = getchar();
        if (isspace(c) || c == '.' || c == '(' || c == ')')
          break;
        append_char(&s, &length, &capacity, tolower(c));
      }
      ungetc(c, stdin);
      return string_to_atom(s);
    }
    }
}

int read_list();

/**
 * Reads and parses the next object from input.
 *
 * @return The identifier of the parsed object.
 */
int read_obj()
{
    int tok = read_token();
    switch (tok) {
    case TOK_OPEN:
    return read_list();
    case TOK_QUOTE:
    tok = read_obj();
    switch (tok) {
    case TOK_CLOSE:
        show_warning("ignoring quote before close parenthesis");
        return tok;
    case TOK_DOT:
        show_warning("ignoring quote before dot");
        return tok;
    case TOK_ERROR:
        return tok;
    default:
        return alloc_cons(atom_quote, alloc_cons(tok, 0));
    }
    default:
    return tok;
    }
}

/**
 * Reads and parses a list from input.
 *
 * @return The identifier of the parsed list.
 */
int read_list()
{
    int sh = read_obj();
    int st;
    switch (sh) {
    case TOK_ERROR:
    return TOK_ERROR;
    case TOK_CLOSE:
    return 0;
    case TOK_DOT:
    sh = read_obj();
    switch (sh) {
    case TOK_ERROR:
        return TOK_ERROR;
    case TOK_DOT:
    case TOK_CLOSE:
        show_error("a dot must be followed by an object");
        return TOK_ERROR;
    }
    st = read_list();
    if (st == TOK_ERROR)
        return TOK_ERROR;
    if (st != 0) {
        show_error("only one object may follow a dot");
        return TOK_ERROR;
    }
    return sh;
    default:
    st = read_list();
    if (st == TOK_ERROR)
        return TOK_ERROR;
    return alloc_cons(sh, st);
    }
}

void write_obj(int s);

/**
 * Writes a list represented by a cons cell structure to the standard output.
 *
 * @param s The cons cell representing the list.
 */
void write_list(cons_cell s)
{
    write_obj(s.car);
    int st = s.cdr;

    if (st == 0) {
    return;
    }

    if (cons_cells[st].type == BT_CONS) {
    printf(" ");
    write_list(cons_cells[st]);
    } else {
    printf(" . ");
    write_obj(st);
    }
}

/**
 * Writes a list represented by a cons cell structure to the standard output.
 *
 * @param s The cons cell representing the list.
 */
void write_obj(int s)
{
    if (s == 0) {
    puts("nil");
    return;
    }
    if (s == TOK_ERROR) {
    puts("[ERROR]");
    return;
    }
    switch (cons_cells[s].type) {
    case BT_ATOM:
      printf("%s", atom_table[cons_cells[s].id]);
    break;
    case BT_NUM:
    printf("%lld", cons_cells[s].id);
    break;
    case BT_CONS:
    printf("(");
    if (s != 0) {
        write_list(cons_cells[s]);
    }
    printf(")");
    break;
    case BT_FREE:
    printf("[NULL]");
    break;
    case BT_FORM:
    printf("[syntax]");
    break;
    case BT_FUNCTION:
    printf("[function]");
    break;
    case BT_BUILTIN:
    printf("[built in function]");
    break;
    default:
    printf("[???]");
    }
}

/**
 * Defines a new variable 'var' with the specified value 'aval' within the given
 * environment 'env'. If the variable already exists within the environment, its
 * value is updated. If the variable is not found, a new binding is created.
 *
 * @param var  The identifier of the variable to be defined or updated.
 * @param aval The value to associate with the variable.
 * @param env  The environment (a linked list of frames) in which to define or
 * update the variable.
 * @return The identifier of the defined or updated variable.
 */
int defvar(int var, int aval, int env)
{
    int frame = car(env);
    int vars = car(frame);
    int vals = cdr(frame);
    int64_t vid = cons_cells[var].id;
    while (vars != 0) {
    if (cons_cells[vars].type == BT_ATOM) {
        if (cons_cells[vars].id == vid) {
        int oid = car(vals);
        cons_cells[vals].car = aval;
        return var;
        } else {
        break;
        }
    }

    if (cons_cells[car(vars)].id == vid) {
        cons_cells[vals].car = aval;
        return var;
    }
    vars = cdr(vars);
    vals = cdr(vals);
    }
    vars = car(frame);
    vals = cdr(frame);
    cons_cells[frame].car = alloc_cons(var, vars);
    cons_cells[frame].cdr = alloc_cons(aval, vals);
    return var;
}

/**
 * Updates the value associated with a variable identified by 'var' within the
 * given environment 'env'. If the variable is found and updated successfully,
 * the function returns the old value of the variable. If the variable is not
 * found, an error message is displayed, and TOK_ERROR is returned.
 *
 * @param var  The identifier of the variable to be updated.
 * @param aval The new value to associate with the variable.
 * @param env  The environment (a linked list of frames) in which to search for
 * and update the variable.
 * @return The old value of the variable if found and updated, or TOK_ERROR if
 * the variable is unbound.
 */
int setvar(int64_t var, int aval, int env)
{
    while (env) {
    int frame = car(env);
    int vars = car(frame);
    int vals = cdr(frame);
    while (vars != 0) {
        if (cons_cells[vars].type == BT_ATOM) {
        if (cons_cells[vars].id == var) {
            int oid = car(vals);
            cons_cells[vals].car = aval;
            return oid;
        } else {
            break;
        }
        }
        if (cons_cells[car(vars)].id == var) {
        int oid = car(vals);
        cons_cells[vals].car = aval;
        return oid;
        }
        vars = cdr(vars);
        vals = cdr(vals);
    }
    env = cdr(env);
    }
    show_error("ubound variable: %s", atom_table[var]);
    return TOK_ERROR;
}

/**
 * Searches for a variable with the specified identifier 'var' within the given
 * environment 'env'. If the variable is found, its associated value is
 * returned. If the variable is not found, an error message is displayed, and
 * TOK_ERROR is returned.
 *
 * @param var The identifier of the variable to be looked up.
 * @param env The environment (a linked list of frames) in which to search for
 * the variable.
 * @return The value associated with the variable if found, or TOK_ERROR if the
 * variable is undefined.
 */
int lookup(int var, int env)
{
    while (env) {
    int frame = car(env);
    int vars = car(frame);
    int vals = cdr(frame);
    while (vars) {
        if (cons_cells[vars].type == BT_ATOM) {
        if (cons_cells[vars].id == var) {
            return vals;
        } else {
            break;
        }
        }

        if (cons_cells[car(vars)].id == var) {
        return car(vals);
        }
        vars = cdr(vars);
        vals = cdr(vals);
    }
    env = cdr(env);
    }
    show_error("undefined variable: %s", atom_table[var]);
    return TOK_ERROR;
}

int eval_obj(int id, int env);

/**
 * Evaluates a list of expressions identified by 'id' within the given
 * environment 'env'. Each expression in the list is evaluated, and a new list
 * containing the results is created.
 *
 * @param id  The identifier of the list of expressions to be evaluated.
 * @param env The environment in which to evaluate the expressions.
 * @return An evaluated list containing the results of evaluating each
 * expression, or 0 if 'id' is not a list.
 */
int lvals(int id, int env)
{
    if (cons_cells[id].type == BT_CONS) {
    int ecar = eval_obj(car(id), env);
    int head = alloc_cons(ecar, 0);
    int l = cdr(id), prev = head;
    while (l) {     // iterate through the list and evaluate each element

        ecar = eval_obj(car(l), env);
        int nc = alloc_cons(ecar, 0);
        cons_cells[prev].cdr = nc;
        prev = nc;
        l = cdr(l);
    }
    return head;
    } else {
    return 0;
    }
}

#define PPLUS 1
#define PMINUS 2
#define PTIMES 3
#define PCONS 4
#define PCAR 5
#define PCDR 6
#define PEQUAL 7
#define PNOT 8
#define PEQ 9
#define PSETCAR 10
#define PSETCDR 11
#define PAPPLY 12
#define PLIST 13
#define PREAD 14
#define PLT 15
#define PGT 16
#define PGEQ 17
#define PLEQ 18
#define PNUMP 20
#define PPROCP 21
#define PSYMP 22
#define PCONSP 24

/**
 * Evaluates a given expression 'id' with a list of arguments 'args'.
 * Depending on the type of 'id' (function or builtin), it performs the
 * corresponding evaluation.
 *
 * For functions:
 *   - Creates a new environment with parameter bindings and evaluates the
 * function's body.
 *   - Returns the result of evaluating the function's body.
 *
 * For builtins:
 *   - Handles various builtin operations based on the 'id':
 *     - Arithmetic operations (PPLUS, PTIMES, PMINUS)
 *     - Logical operations (PNOT)
 *     - List operations (PCONS, PCAR, PCDR, PLIST)
 *     - Input and output (PREAD)
 *     - Type checks (PSYMP, PNUMP, PPROCP, PCONSP)
 *     - Mutation operations (PSETCAR, PSETCDR)
 *     - Equality checks (PEQUAL, PEQ)
 *     - Comparison operations (PLT, PGT, PLEQ, PGEQ)
 *
 * If 'id' is not a function or builtin, an error message is displayed.
 *
 * @param id   The identifier of the expression to be evaluated.
 * @param args The list of arguments for the evaluation.
 * @return The result of the evaluation or TOK_ERROR if there is an error.
 */

int apply(int id, int args)
{
    if (cons_cells[id].type == BT_FUNCTION) {
    int params = car(id);
    int body = cadr(id);
    int procenv = cddr(id);
    int env = alloc_cons(alloc_cons(params, args), procenv);
    while (cdr(body)) {
        eval_obj(car(body), env);
        body = cdr(body);
    }
    return eval_obj(car(body), env);
    } else if (cons_cells[id].type == BT_BUILTIN) {
    switch (cons_cells[id].id) {
    case PPLUS:
    case PTIMES:{
        int64_t sum = (cons_cells[id].id == PPLUS) ? 0 : 1;

        for (int a = args; a; a = cdr(a)) {
            if (cons_cells[id].id == PPLUS) {
            sum += cons_cells[car(a)].id;
            } else if (cons_cells[id].id == PTIMES) {
            sum *= cons_cells[car(a)].id;
            }
        }

        int p = alloc();
        cons_cells[p].type = BT_NUM;
        cons_cells[p].id = sum;
        return p;
        }
    case PNOT:
        return car(args) ? 0 : atom_true;
    case PCONS:
        return alloc_cons(car(args), cadr(args));
    case PCAR:
        return car(car(args));
    case PCDR:
        return cdr(car(args));
    case PAPPLY:
        return apply(car(args), cadr(args));
    case PLIST:
        return args;
    case PREAD:
        return read_obj();
    case PSYMP:
        return cons_cells[car(args)].type == BT_ATOM ? atom_true : 0;
    case PNUMP:
        return cons_cells[car(args)].type == BT_NUM ? atom_true : 0;
    case PPROCP:
        return cons_cells[car(args)].type == BT_FUNCTION ||
        cons_cells[car(args)].type == BT_BUILTIN ? atom_true : 0;
    case PCONSP:
        return cons_cells[car(args)].type == BT_CONS ? atom_true : 0;
    case PSETCAR:{
        int arg1 = car(args);
        int arg2 = cadr(args);
        return cons_cells[arg1].car = arg2;
        }
    case PSETCDR:{
        int arg1 = car(args);
        int arg2 = cadr(args);
        return cons_cells[arg1].cdr = arg2;
        }
    case PMINUS:{
        int64_t arg1 = cons_cells[car(args)].id;
        int rargs = cdr(args);
        if (rargs) {
            int64_t res = arg1;
            while (rargs) {
            res -= cons_cells[car(rargs)].id;
            rargs = cdr(rargs);
            }
            int p = alloc();
            cons_cells[p].type = BT_NUM;
            cons_cells[p].id = res;
            return p;
        } else {
            int p = alloc();
            cons_cells[p].type = BT_NUM;
            cons_cells[p].id = -arg1;
            return p;
        }
        }
    case PEQUAL:{
        if (!args)
            return atom_true;
        int64_t f = cons_cells[car(args)].id;
        int64_t a = cdr(args);
        while (a) {
            if (cons_cells[car(a)].id != f)
            return 0;
            a = cdr(a);
        }
        return atom_true;
        }
    case PEQ:{
        int arg1 = car(args);
        int arg2 = cadr(args);
        if (cons_cells[arg1].type != cons_cells[arg2].type)
            return 0;
        switch (cons_cells[arg1].type) {
        case BT_NUM:
        case BT_FUNCTION:
        case BT_BUILTIN:
        case BT_ATOM:
            return cons_cells[arg1].id ==
            cons_cells[arg2].id ? atom_true : 0;
        default:
            return arg1 == arg2 ? atom_true : 0;
        }

        return atom_true;
        }

    case PLT:
    case PGT:
    case PLEQ:
    case PGEQ:{
        if (!args) {
            return atom_true;
        }

        int64_t f = cons_cells[car(args)].id;
        int a = cdr(args);

        while (a) {
            int current_value = cons_cells[car(a)].id;

            if ((cons_cells[id].id == PLT && f < current_value) ||
            (cons_cells[id].id == PGT && f > current_value) ||
            (cons_cells[id].id == PLEQ && f <= current_value)
            || (cons_cells[id].id == PGEQ
                && f >= current_value)) {
            f = current_value;
            a = cdr(a);
            } else {
            return 0;
            }
        }
        return atom_true;
        }
    }

    } else {
    show_error("bad application: not a function");
    return TOK_ERROR;
    }
}

/**
 * Evaluates an object (atom, number, function, or list) within a specified
 * environment.
 *
 * @param id  The identifier of the object to be evaluated.
 * @param env The environment in which the evaluation takes place.
 * @return    The result of the evaluation.
 */
int eval_obj(int id, int env)
{
    if (!id)
    return 0;
    switch (cons_cells[id].type) {
    case BT_NUM:
    case BT_FUNCTION:
    case BT_BUILTIN:
    return id;
    case BT_CONS:
    if (cons_cells[cons_cells[id].car].type == BT_ATOM) {
        int x = cons_cells[car(id)].id;
        if (x == intern("quote")) {
        return cadr(id);
        } else if (x == intern("lambda")) {
        int p = alloc();
        cons_cells[p].type = BT_FUNCTION;
        cons_cells[p].car = cadr(id);
        cons_cells[p].cdr = alloc_cons(cddr(id), env);
        return p;
        } else if (x == intern("begin")) {
        int seq = cdr(id);
        while (cdr(seq)) {
            eval_obj(car(seq), env);
            seq = cdr(seq);
        }
        return eval_obj(car(seq), env);
        } else if (x == intern("and")) {
        int seq = cdr(id);
        while (cdr(seq)) {
            int t = eval_obj(car(seq), env);
            if (!t)
            return 0;
            seq = cdr(seq);
        }
        return eval_obj(car(seq), env);
        } else if (x == intern("or")) {
        int seq = cdr(id);
        while (cdr(seq)) {
            int t = eval_obj(car(seq), env);
            if (t)
            return t;
            seq = cdr(seq);
        }
        return eval_obj(car(seq), env);
        } else if (x == intern("cond")) {
        int clauses = cdr(id);
        while (clauses) {
            int clause = car(clauses);
            int praedicate = car(clause);
            if (eval_obj(praedicate, env)) {
            int seq = cdr(clause);
            while (cdr(seq)) {
                eval_obj(car(seq), env);
                seq = cdr(seq);
            }
            return eval_obj(car(seq), env);
            }
            clauses = cdr(clauses);
        }
        } else if (x == intern("set!")) {
        int64_t vid = cons_cells[cadr(id)].id;
        int aval = caddr(id);
        return setvar(vid, eval_obj(aval, env), env);
        } else if (x == intern("define")) {
        int64_t vid = cadr(id);
        int aval = caddr(id);
        if (cons_cells[vid].type == BT_CONS) {
            int p = alloc();
            cons_cells[p].type = BT_FUNCTION;
            cons_cells[p].car = cdr(vid);
            cons_cells[p].cdr = alloc_cons(cddr(id), env);
            return defvar(car(vid), p, env);
        }
        return defvar(vid, eval_obj(aval, env), env);
        } else if (x == intern("if")) {
        int protasis = cadr(id);
        int apodosis = caddr(id);
        int alt = cadddr(id);
        return eval_obj(protasis, env) ? eval_obj(apodosis, env)
            : eval_obj(alt, env);
        } else {
        int args = cdr(id);
        int proc = eval_obj(car(id), env);
        return apply(proc, lvals(args, env));
        }
    } else {
        int args = cdr(id);
        int proc = eval_obj(car(id), env);
        return apply(proc, lvals(args, env));
    }
    case BT_ATOM:
    return lookup(cons_cells[id].id, env);
    case BT_FREE:
    show_error("attempt to evaluate free memory");
    return TOK_ERROR;
    default:
    return id;
    }
}

/**
 * Creates an empty environment with no variable bindings.
 *
 * @return The identifier of the empty environment.
 */
int empty_environment()
{
    int vars = 0, vals = 0;
    int frame = alloc_cons(vars, vals);
    return alloc_cons(frame, 0);
}

/**
 * Creates a new primitive operation (builtin) with the given identifier 'id'.
 *
 * @param id The identifier of the primitive operation.
 * @return The identifier of the created primitive operation.
 */
int mk_primop(int id)
{
    int p = alloc();
    cons_cells[p].type = BT_BUILTIN;
    cons_cells[p].id = id;
    return p;
}



/**
 * Creates and initializes the default environment with predefined primitive
 * operations.
 *
 * @return The identifier of the default environment.
 */
int default_environment()
{
    int env = empty_environment();
    defvar(string_to_atom("+"), mk_primop(PPLUS), env);
    defvar(string_to_atom("-"), mk_primop(PMINUS), env);
    defvar(string_to_atom("*"), mk_primop(PTIMES), env);
    defvar(string_to_atom("cons"), mk_primop(PCONS), env);
    defvar(string_to_atom("car"), mk_primop(PCAR), env);
    defvar(string_to_atom("cdr"), mk_primop(PCDR), env);
    defvar(string_to_atom("="), mk_primop(PEQUAL), env);

    defvar(string_to_atom("not"), mk_primop(PNOT), env);
    defvar(string_to_atom("eq?"), mk_primop(PEQ), env);
    defvar(string_to_atom("eqv?"), mk_primop(PEQ), env);
    defvar(atom_true, atom_true, env);  // true
    defvar(string_to_atom("set-car!"), mk_primop(PSETCAR), env);
    defvar(string_to_atom("set-cdr!"), mk_primop(PSETCDR), env);
    defvar(string_to_atom("apply"), mk_primop(PAPPLY), env);
    defvar(string_to_atom("list"), mk_primop(PLIST), env);
    defvar(string_to_atom("read"), mk_primop(PREAD), env);

    defvar(string_to_atom("<"), mk_primop(PLT), env);
    defvar(string_to_atom(">"), mk_primop(PGT), env);
    defvar(string_to_atom(">="), mk_primop(PGEQ), env);
    defvar(string_to_atom("<="), mk_primop(PLEQ), env);

    defvar(string_to_atom("symbol?"), mk_primop(PSYMP), env);
    defvar(string_to_atom("number?"), mk_primop(PNUMP), env);
    defvar(string_to_atom("procedure?"), mk_primop(PPROCP), env);
    defvar(string_to_atom("pair?"), mk_primop(PCONSP), env);

    return env;
}

/**
 * The main entry point of the program. Initializes variables and enters an
 * infinite loop to read, evaluate, and print Lisp expressions.
 *
 * @return The exit code of the program (not used in this case).
 */
int main()
{

  atom_quote = string_to_atom("quote");
  atom_true = string_to_atom("t");
  int env = default_environment();

    for (;;) {
    printf("]=> ");
    fflush(stdin);

    int x = eval_obj(read_obj(), env);
    printf("\n;Value: ");
    write_obj(x);
    puts("");
    }
}
\$\endgroup\$
7
  • 3
    \$\begingroup\$ Everything in a single file? Alright. Are there any tests? What C Standard are you aiming to conform to? C89, C99, C11, C17, or C23? \$\endgroup\$
    – Harith
    Commented Jun 14 at 1:54
  • 5
    \$\begingroup\$ "basic Scheme" Excellent! So we won't hold you to something as fancy as scheme r7rs. But still, please do tell us what spec you strive to conform to and test against. When I hear "scheme" I immediately assume TCO; certainly Revised^5 spells this out. It would be very helpful to see the scheme source code in your test suite. It would be entertaining to see {success, failure} of trying to load standard libraries attempting to implement reader macro support and some recent language features. \$\endgroup\$
    – J_H
    Commented Jun 14 at 2:58
  • 1
    \$\begingroup\$ It would have been nicer if you had added some basic overview of the language in your post. After some looking: "Scheme is a minimalist dialect of the Lisp family of programming languages." Okay, not my cup of tea. I did find a lot of C implementations on the main page. It might benefit you to give them a read. \$\endgroup\$
    – Harith
    Commented Jun 14 at 3:10
  • 1
    \$\begingroup\$ Does Greenspun's tenth rule apply here? \$\endgroup\$
    – tevemadar
    Commented Jun 14 at 12:52
  • 4
    \$\begingroup\$ @Harith hey, hey, play nice! It's advertised as a basic scheme, set your expectations appropriately. There's a very nice KLOC of code here, a working PoC of a little lisp, which may become bigger later. I have a few meg of memory to spare. Arlo Guthrie explained the Alice's Restaurant GC policy: "...and having all that room, seeing as how they took out all the pews, they decided that they didn't have to take out their garbage for a long time." \$\endgroup\$
    – J_H
    Commented Jun 14 at 15:25

2 Answers 2

12
\$\begingroup\$

Reserved identifiers:

Code defines string_to_atom(), a function name prefixed with str and followed by a lowercase letter, which was reserved for use by <string.h>. So your code technically invokes undefined behavior.

@David Conrad suggests changing it to atom_from_string() instead.

For Clang, use -Wreserved-identifier to get a warning for such cases. GCC has no equivalent flag.

Each call to malloc() and family should have a corresponding call to the free() function:

In append_char(), we have a call to realloc():

void append_char(char **str, size_t *len, size_t *cap, char ch) {
    if (*len + 1 >= *cap) {
        *cap = (*cap == 0) ? 1 : (*cap * 2);
        *str = realloc(*str, *cap);

But there is no corresponding call to free(). Your interpreter is never freeing the memory it allocates. Consider running the executable with the valgrind program to find such leaks.

About fixing the leak, you need to call free() in read_token() after string_to_atom() returns.

Remove unused variable:

In defvar(), you have:

if (cons_cells[vars].id == vid) {
        int oid = car(vals);
        cons_cells[vals].car = aval;
        return var;

As oid is never used, elide it.

Incorrect format specifier:

Compiling with GCC 14.1 with -Wall -Werror -Wexta, I get:

<source>: In function 'write_obj':
<source>:414:16: error: format '%lld' expects argument of type 'long long int', but argument 2 has type 'int64_t' {aka 'long int'} [-Werror=format=]
  414 |     printf("%lld", cons_cells[s].id);
      |             ~~~^   ~~~~~~~~~~~~~~~~
      |                |                |
      |                long long int    int64_t {aka long int}
      |             %ld

The fix is simple is to use the correct format specifier, PRIu64. Note that the code currently invokes undefined behavior due to a mismatch between the format specifier and the corresponding argument.

A label can only be part of a statement and a declaration is not a statement:

In read_token(), you have:

default:
      char *s = NULL;

Prior to C23, a label (cleanup:) is not allowed to appear immediately before a declaration (such as char *str ...;), only before a statement (printf(...);).

You can put a semicolon immediately after the label's colon for an empty statement.

Signed to unsigned conversions:

GCC reports a lot of these, I'd simply show the warnings:

In function 'string_to_atom':
<source>:207:13: warning: conversion to 'size_t' {aka 'long unsigned int'} from 'long int' may change the sign of the result [-Wsign-conversion]
  207 |         y = endptr - s;
      |             ^~~~~~

and:

<source>:283:43: warning: conversion from 'int' to 'char' may change value [-Wconversion]
  283 |       append_char(&s, &length, &capacity, c);
      |                                           ^
<source>:289:45: warning: conversion from 'int' to 'char' may change value [-Wconversion]
  289 |         append_char(&s, &length, &capacity, tolower(c));
      |                                             ^~~~~~~~~~

and:

<source>: In function 'apply':
<source>:737:32: warning: conversion from 'int64_t' {aka 'long int'} to 'int' may change value [-Wconversion]
  737 |             if (cons_cells[car(a)].id != f)
      |                                ^
<source>:739:21: warning: conversion from 'int64_t' {aka 'long int'} to 'int' may change value [-Wconversion]
  739 |             a = cdr(a);
      |                     ^
<source>:774:33: warning: conversion from 'int64_t' {aka 'long int'} to 'int' may change value [-Wconversion]
  774 |             int current_value = cons_cells[car(a)].id;
      |                                 ^~~~~~~~~~
<source>: In function 'eval_obj':
<source>:816:17: warning: conversion from 'int64_t' {aka 'long int'} to 'int' may change value [-Wconversion]
  816 |         int x = cons_cells[car(id)].id;
      |                 ^~~~~~~~~~
<source>:875:37: warning: conversion from 'int64_t' {aka 'long int'} to 'int' may change value [-Wconversion]
  875 |             cons_cells[p].car = cdr(vid);
      |                                     ^~~
<source>:877:31: warning: conversion from 'int64_t' {aka 'long int'} to 'int' may change value [-Wconversion]
  877 |             return defvar(car(vid), p, env);
      |                               ^~~
<source>:879:23: warning: conversion from 'int64_t' {aka 'long int'} to 'int' may change value [-Wconversion]
  879 |         return defvar(vid, eval_obj(aval, env), env);
      |                       ^~~
<source>:897:33: warning: conversion from 'int64_t' {aka 'long int'} to 'int' may change value [-Wconversion]
  897 |     return lookup(cons_cells[id].id, env);
      |                   ~~~~~~~~~~~~~~^~~

Always compile with warnings enabled. I would suggest:

-std=c23 -g3 -ggdb -no-pie -Wall -Wextra -Warray-bounds -Wconversion -Wformat-signedness -Wmissing-braces -Wno-parentheses -Wpedantic -Wstrict-prototypes -Wwrite-strings -Winline -s -fno-builtin -fno-common -fno-omit-frame-pointer -fsanitize=float-cast-overflow -fsanitize=address -fsanitize=undefined -fsanitize=leak

Though, you no longer have to remember format specifiers like PRIu32 et cetera. C23 has introduced:

wN Specifies that a following b, B, d, i, o, u, x, or X conversion specifier applies to an integer argument with a specific width where N is a positive decimal integer with no leading zeros (the argument will have been promoted according to the integer promotions, but its value shall be converted to the unpromoted type); or that a following n conversion specifier applies to a pointer to an integer type argument with a width of N bits. All minimum-width integer types (7.22.1.2) and exact-width integer types (7.22.1.1) defined in the header <stdint.h> shall be supported. Other supported values of N are implementation-defined.

wfN Specifies that a following b, B, d, i, o, u, x, or X conversion specifier applies to a fastest minimum-width integer argument with a specific width where N is a positive decimal integer with no leading zeros (the argument will have been promoted according to the integer promotions, but its value shall be converted to the unpromoted type); or that a following n conversion specifier applies to a pointer to a fastest minimum-width integer type argument with a width of N bits. All fastest minimum-width integer types (7.22.1.3) defined in the header <stdint.h> shall be supported. Other supported values of N are implementation-defined.

So %w32d for int32_t, %w64d for int64_t, and so on.

Functions from <ctype.h> expect a value in the unsigned char or EOF range:

In string_to_atom(), you have:

// Check if the string represents a number
if ((s[0] == '-' && isdigit(s[1])) || isdigit(s[0])) {

According to the ISO C standard:

7.4

1 The header <ctype.h> declares several functions useful for classifying and mapping characters. In all cases the argument is an int, the value of which shall be representable as an unsigned char or shall equal the value of the macro EOF. If the argument has any other value, the behavior is undefined.

The cast to unsigned char ensures calling isalpha() does not invoke Undefined Behaviour.

Casting a char to an unsigned char works for 2's complement, but not other rare encodings. Accessing the characters via unsigned char * is best. (This is not a problem in C23.)

fflush(stdin) is undefined behavior:

From 7.23.5.2 The fflush function, ISO/IEC 9899:2024:

2 If stream points to an output stream or an update stream in which the most recent operation was not input, the fflush function causes any unwritten data for that stream to be delivered to the host environment to be written to the file; otherwise, the behavior is undefined.

printf("]=> ");
fflush(stdin);

But this was likely meant to flush standard output, so it is an small fix.

Empty argument list vs void in function declarations:

In C:

  • void foo() means "a function foo taking an unspecified number of arguments of unspecified type".
  • void foo(void) means "a function foo taking no arguments"

C23 adopted C++'s semantics, so an empty argument list now means that the function takes no arguments, and () is once again fine to use. And those who have lived underneath a rock for 25 years need not worry either.

I do not believe this code is using C23, so I'd suggest adding void everywhere.

Only declare as many variables as you require:

/**
 * Creates an empty environment with no variable bindings.
 *
 * @return The identifier of the empty environment.
 */
int empty_environment()
{
    int vars = 0, vals = 0;
    int frame = alloc_cons(vars, vals);
    return alloc_cons(frame, 0);
}

vars, vals, and frame are not referenced again. So it can be simplified to:

return alloc_cons(alloc_cons(0, 0), 0);

Redundant documentation:

/**
 * Returns the 'car' (first element) of the 'cdr' (rest) of the 'cdr' (rest) of
 * the 'cdr' (rest) of a cons cell identified by its ID.
 *
 * @param id The ID of the cons cell.
 * @return The 'car' of the 'cdr' of the 'cdr' of the 'cdr'.
 */

Why are we stating what it returns twice? The function has only 1 line of code, but 7 lines of comments. Same goes for other functions.

Consider linking to some official specification, @J_H suggests Steele, and removing this fluff.

After removing the comments:

int car(int id)
{
    return cons_cells[id].car;
}

int cdr(int id)
{
    return cons_cells[id].cdr;
}

int cadr(int id)
{
    return car(cdr(id));
}

int cddr(int id)
{
    return cdr(cdr(id));
}

int caddr(int id)
{
    return car(cdr(cdr(id)));
}

int cdddr(int id)
{
    return cdr(cdr(cdr(id)));
}

int cadddr(int id)
{
    return car(cdr(cdr(cdr(id))));
}

Or even simpler, and shorter:

int car(int id)    { return cons_cells[id].car;     }
int cdr(int id)    { return cons_cells[id].cdr;     }
int cadr(int id)   { return car(cdr(id));           }
int cddr(int id)   { return cdr(cdr(id));           }
int caddr(int id)  { return car(cdr(cdr(id)));      }
int cdddr(int id)  { return cdr(cdr(cdr(id)));      }
int cadddr(int id) { return car(cdr(cdr(cdr(id)))); }

Note that cdddr() can use cddr(cdr(id)) instead of cdr(cdr(cdr(id))), and cadddr() can use car(cdddr(id)) instead of car(cdr(cdr(cdr(id)))), and so on.

But note: It is common for a scheme to evaluate an init.scm source file before displaying a REPL prompt. It might set up various important language features, perhaps defined in a SRFI; cf "Many ... syntactic forms of the language are now part of the (rnrs base (6)) library" – @J_H.

Having large static arrays can cause running process to be bloated:

/**
 * Allocates a new memory cell and returns its identifier.
 *
 * @return The identifier of the newly allocated memory cell.
 */
int alloc()
{
    return hptr++;
}

What is being "allocated" here? This simply increments a counter and returns.

Looks like you're keeping two file-scope arrays with external linkage:

int hptr = 10;

#define TABLE_SIZE 999983
cons_cell cons_cells[TABLE_SIZE];
const char *atom_table[TABLE_SIZE];

Firstly, these should both have internal linkage, i.e. be prefixed with the static keyword. Secondly, there is never a need to allocate 999983 bytes and 999983 pointers. Do not fear dynamic memory allocation. These arrays might never get fully populated (wasting memory), or they might overflow, because there is no check, and the program would then invoke undefined behavior. See also: How do global variables contribute to the size of the executable?.

Consider what happens when you run out of cells. Where would the new cells go? I would suggest using malloc() and realloc(). Start with a decent size, and then regrow exponentially each time the arrays get full.

Beside that, an int may only have 16 bits, in which it would not be able to hold values up to TABLE_SIZE. I would suggest removing all instances of int with exact-width standard integer types like int32_t, uint32_t, int64_t et cetera.

Also note that if hptr was to overflow, your code would invoke undefined behavior, because signed integer overflow is undefined behavior.

exit(0) indicates success:

#define show_error(...) do { fprintf(stderr, __VA_ARGS__); exit(0); } while(0)

Instead of exiting with magic numbers, use EXIT_SUCCESS and EXIT_FAILURE from <stdlib.h>.

Problems with string_to_atom():

    size_t n = strlen(s);
    size_t y = 0;
    int64_t nval = 0;
    
    // Check if the string represents a number
    if ((s[0] == '-' && isdigit(s[1])) || isdigit(s[0])) {
        char *endptr;
        nval = strtoll(s, &endptr, 0);
        y = endptr - s;
    }

Firstly, strlen() can return 0 if the first character was '\0'. You did not check for that case. Furthermore, s[1] and [0] might be out of bounds, in which case your program would invoke undefined behavior. Moreover, strtoll() can fail:

The strtol() function returns the result of the conversion, unless the value would underflow or overflow. If an underflow occurs, strtol() returns LONG_MIN. If an overflow occurs, strtol() returns LONG_MAX. In both cases, errno is set to ERANGE. Precisely the same holds for strtoll() (with LLONG_MIN and LLONG_MAX instead of LONG_MIN and LONG_MAX).

Potential integer overflow:

In append_char(), we have:

void append_char(char **str, size_t *len, size_t *cap, char ch) {
        if (*len + 1 >= *cap) {
            *cap = (*cap == 0) ? 1 : (*cap * 2);
            *str = realloc(*str, *cap);
            if (*str == NULL) {
                perror("Failed to allocate memory");
                exit(EXIT_FAILURE);
            }
        }
        (*str)[(*len)++] = ch;
        (*str)[*len] = '\0';
}

The unchecked multiplication *cap * 2 poses a significant risk. If an overflow occurs, the result will wrap around, leading to fewer allocated bytes than intended. This could result in the program continuing execution without recognizing the error.

Consider using C23's ckd_mul() function from <stdckint.h>. Both GCC 14.1 and Clang 18.1 implement it.

But then the additions *len + 1 and (*len)++ can also overflow. These could use ckd_add().

And to run cleanly under valgrind, free the allocated memory before calling exit(EXIT_FAILURE). Though ideally, I'd prefer seeing a return EXIT_FAILURE from main().

Lying comments:

We have a copy-paste error here:

/**
 * Returns the 'car' (first element) of the 'cdr' (rest) of a cons cell
 * identified by its ID.
 *
 * @param id The ID of the cons cell.
 * @return The 'car' of the 'cdr'.
 */
int cadr(int id)
{
    return car(cdr(id));
}

/**
 * Returns the 'car' (first element) of the 'cdr' (rest) of a cons cell
 * identified by its ID.
 *
 * @param id The ID of the cons cell.
 * @return The 'car' of the 'cdr'.
 */
int cddr(int id)
{
    return cdr(cdr(id));
}

Both cadr() and cddr() have the same documentation. cddr() lies, it does not return the "'car' (first element) of the 'cdr'...". It returns the 'cdr' of the 'cdr'...

Documentation is appreciated and wonderful. Wrong documentation is frowned upon and frustrating.

Wrong usage of realloc():

In append_char():

*str = realloc(*str, *cap);

If realloc() returned a null pointer, you would lose the only reference to the original allocation and leak memory. Consider doing:

void *const tmp = realloc(*str, *cap);

if (tmp) {
    *str = tmp;
} else {
    free(str);
    // Now exit
}

Check for EOF:

int read_token()
{
    int c;
    for (;;) {
    c = getchar();
    while (isspace(c))
        c = getchar();

c might be EOF, in which case you would keep looping. Consider moving this to a helper function named skip_whitespace() or similar.

Prefer unsigned types over signed types:

You're using an int everywhere for holding sizes and indices. It is not possible for an index or size to be signed. I'd suggest using size_t.

Format your code:

As is, the code is very hard to read and understand (I skipped most of it due to bad formatting), the braces are all over the place, and there is a lot of unnecessary vertical whitespace, which again hinders readability.

Consider using an automatic code formatter like clang-format, GNU Indent, Astyle, et cetera.

Prefer enum to #define:

#define TOK_NIL 0
#define TOK_ERROR 1
#define TOK_OPEN 2
#define TOK_CLOSE 3
#define TOK_QUOTE 4
#define TOK_DOT 5

can be:

enum tokens {
    TOK_NIL,
    TOK_ERROR,
    TOK_OPEN,
    TOK_CLOSE,
    TOK_QUOTE,
    TOK_DOT,
};

This has four benefits:

  • Under a debugger, you'd not see magic values like 0, 1, 2, but named constants like TOK_OPEN, TOK_CLOSE, et cetera.

  • If you miss some value in a switch statement, the compiler would likely warn about it (assuming there is no default, which often hinders the warning).

  • Functions, like read_token(), that return one of the token values can specify the return type to be enum tokens, or just tokens (assuming you create an alias with typedef), instead of int.

  • You can give the enum a type in C23 and above. Macros are simple text replacements, and are type-less.

Simplify:

// int64_t sum = (cons_cells[id].id == PPLUS) ? 0 : 1;

int64_t sum = !(cons_cells[id].id == PPLUS);

Global state and missing unit tests:

As is, the code appears very brittle and keeps a global state, which makes it almost untestable. Code that is not tested, and is untestable, is unreliable code.

I'd suggest making a struct containing all the global variables and then passing it around to the functions that require it. And then writing tests for each function. You do not need something complicated, simple assertions (assert() from <assert.h>) often do.

Then write a Makefile with the following targets:

  • make debug - this would build the default executable with a strict set of warnings and debugging flags enabled, along with static analyzers and sanitizers (-g3 -ggdb -Werror -Wextra -pedantic-errors et cetera).
  • make release - this would build the default executable with optimizations enabled and assertions disabled (-O3 -s -NDEBUG et cetera).
  • make test - this would run all the unit tests (that are yet to be written).
  • make format - this would automatically format the code with one of the afore-mentioned code formatters.
  • make valgrind - this would rebuild the executable without the sanitizers and analyzers (valgrind and AddressSanitizer et cetera do not work together) and then run the executable under the valgrind program.

This translation unit also seems to have an implementation of a hash table. You could move that to a different .c file, and then include the function prototypes with a corresponding .h file. It would decrease the lines of code one has to deal with at a time, make the hash table reusable in other projects, separate the implementation from its use, and allow it to be tested separately from the interpreter.

Also consider giving the user another chance on a syntax error. Python's REPL does not exit when I input some invalid code. It instead offers me a helpful error message and allows me to input again. If some interpreter keeps exiting on syntax errors, I at least would not be very open to using it.

\$\endgroup\$
12
  • 2
    \$\begingroup\$ Sooo, cadr looks fine, but then yeah, on the next one (cddr) it all falls apart. Let us dine upon copy-pasta, the root of all evil! Comments for cadddr look fine, but at that point who reads the English? Just carefully read the A's and D's, as we do with the beautifully phrased cdddr (no comments, good!). By the time I got there on first reading, I was wondering why we don't just cite Steele and be done with it. I was also wondering if scheme functions instead of C functions would suffice. \$\endgroup\$
    – J_H
    Commented Jun 14 at 3:09
  • 1
    \$\begingroup\$ Harith, as far as the pointer bump in alloc() goes, I respectfully disagree about "lying". That seems like a perfectly decent way for the low-level implementation to make new resources available to the high-level scheme app. The invariant is that cells bellow hptr can be mutated by the scheme app, and cells above have never been made available to the app. That's an "allocation" in my book. (BTW, think of "bump allocator" or synonym "arena alloctor" for a C malloc style interface -- same kind of thing. Or... sbrk()!) \$\endgroup\$
    – J_H
    Commented Jun 14 at 3:16
  • 1
    \$\begingroup\$ I agree with @J_H that we should recommend implementing the minimum in C, and using Scheme itself to define cadr and friends (unless we decide to get smart, and actually evaluate the as and ds in the function name). \$\endgroup\$ Commented Jun 14 at 7:57
  • 1
    \$\begingroup\$ "<ctype.h> expect an int cast to an unsigned char" --> not quite. is...() functions expect a value in the unsigned char or EOF range. Casting a char to an unsigned char works for 2's complement, but not other rare encodings. Accessing the characters via unsigned char * is best. \$\endgroup\$ Commented Jun 14 at 18:59
  • 2
    \$\begingroup\$ I completely agree with the remark about the large static arrays. However, I do want to note that in practice this does not cost any memory at all. They will be part of the .bss segment which takes up no space in the compiled binary, and thanks to the way virtual memory works, any parts of it that are unused while the program is running will also not cost any RAM (plus/minus page granularity of course). \$\endgroup\$
    – G. Sliepen
    Commented Jun 15 at 13:15
5
\$\begingroup\$

Around line 300 of this source code I gave up fixing the indentation to see what was what.


Code Review:

Not terribly easy for the reader to follow making its logic "over the horizon" for analysis...

Minimal suggested fix: Use whitespace appropriately and consistently... Also, presume w-i-d-e monitors being used. Gone are the days of 24x80 screens doing code development. (Keep width used within reason, of course!) Hiding nested indents by not indenting is deceptive. Write clean, clear, and especially correct code.


One function examined:

Cutting just the code of apply() and pasting it into an empty file, we see 149 lines of quite unreadable code; unreadable owing to flagrant disregard for indentation.

Below is my attempt to make sense of apply(), requiring only 103 lines of code. (I hope I've not made any "Oops!" mistakes while modifying the OP's code here.) Some comments attempt to highlight some of the compressions made.

This snippet is presented merely to indicate how proper indentation and an aversion to unnecessary curly braces can shrink the volume of long, linear code enabling the readers to perform "spot checks" and otherwise assess program flow. If roughly 30% of the compilable code code be removed or compressed, a source of 1000 lines might be more palatable.

I applaud the code's terse variable and function names. Those who enter must commit to making an effort to understand the coder's rationale and its use. Otherwise, any program listing is no more than ASCII art.

To taste, one blank line between each case : body would be nice. Left to the reader to decide...

int apply( int id, int args ) { // consistent brace location
    if ( cons_cells[id].type == BT_FUNCTION ) {
        int params = car(id);
        int body = cadr(id);
        int procenv = cddr(id);
        int env = alloc_cons(alloc_cons(params, args), procenv);
        for( ; cdr(body); body = cdr(body) ) // for(), not while()
            eval_obj(car(body), env);
        return eval_obj(car(body), env);
    }

    if (cons_cells[id].type != BT_BUILTIN) { // early exit. 1 level of indent saved
        show_error("bad application: not a function");
        return TOK_ERROR;
    }

    switch (cons_cells[id].id) {
        case PPLUS:
        case PTIMES: {
            int op = cons_cells[id].id;
            int64_t sum = (op == PPLUS) ? 0 : 1;

            for (int a = args; a; a = cdr(a))
                     if (op == PPLUS) sum += cons_cells[car(a)].id;
                else if (op == PTIMES) sum *= cons_cells[car(a)].id;

            int p = alloc();
            cons_cells[p].type = BT_NUM;
            cons_cells[p].id = sum;
            return p;
        } // clearly end of local variables' existence
        case PNOT:  return car(args) ? 0 : atom_true;
        case PCONS: return alloc_cons(car(args), cadr(args));
        case PCAR:  return car(car(args));
        case PCDR:  return cdr(car(args));
        case PAPPLY:return apply(car(args), cadr(args));
        case PLIST: return args;
        case PREAD: return read_obj();
        case PSYMP: return cons_cells[car(args)].type == BT_ATOM ? atom_true : 0;
        case PNUMP: return cons_cells[car(args)].type == BT_NUM ? atom_true : 0;
        case PPROCP:    return  cons_cells[car(args)].type == BT_FUNCTION
                        ||      cons_cells[car(args)].type == BT_BUILTIN
                            ? atom_true // return condition true
                            : 0;        // return condition false
        case PCONSP:return cons_cells[car(args)].type == BT_CONS ? atom_true : 0;
        case PSETCAR: return cons_cells[ car(args) ].car = cadr(args);
        case PSETCDR: return cons_cells[ car(args) ].cdr = cadr(args);
        case PMINUS: {
            int64_t res = cons_cells[car(args)].id;
            int rargs = cdr(args);
            if (!rargs) res = -res; // simple negation
            else for ( ; rargs; rargs = cdr(rargs) ) // for(), not while()
                    res -= cons_cells[car(rargs)].id;

            int p = alloc(); // common code NOT duplicated
            cons_cells[p].id = res;
            cons_cells[p].type = BT_NUM;
            return p;
        }
        case PEQUAL: {
            if (args) {
                int64_t f = cons_cells[car(args)].id;
                for( int64_t a = cdr(args); a; a = cdr(a) )
                    if (cons_cells[car(a)].id != f)
                        return 0;
            }
            return atom_true;
        }
        case PEQ: {
            int arg1 = car(args);
            int arg2 = cadr(args);
            if (cons_cells[arg1].type != cons_cells[arg2].type) return 0;
            switch (cons_cells[arg1].type) {
                case BT_NUM:
                case BT_FUNCTION:
                case BT_BUILTIN:
                case BT_ATOM:
                    return cons_cells[arg1].id == cons_cells[arg2].id ? atom_true : 0;
                default: // default? Or move outside of switch()?
                    return arg1 == arg2 ? atom_true : 0;
            }
        }
        case PLT:
        case PGT:
        case PLEQ:
        case PGEQ: {
            if (!args) return atom_true;

            int64_t f = cons_cells[car(args)].id;
            for( int a = cdr(args); a; a = cdr(a) ) {
                int current_value = cons_cells[car(a)].id;

                if ((cons_cells[id].id == PLT && f < current_value)
                ||  (cons_cells[id].id == PGT && f > current_value)
                ||  (cons_cells[id].id == PLEQ && f <= current_value)
                ||  (cons_cells[id].id == PGEQ && f >= current_value))
                    f = current_value;
                else return 0;
            }
            return atom_true;
        }
    }
}

Looking at this again, I'd suggest moving those (quite independent) operations involving automatic variables and several lines of code each into its own tiny "helper function". Then apply() would be much more a simple switch() that fits on one screen, and each case : could be evaluated independently. A reader reads code at varying levels of magnification, sometimes up close and sometimes gaining an overview. Make your readers happy!

Below is one such helper function, untested:

int apply_plus_mult( int id, int args ) {
    int op = cons_cells[id].id;
    int64_t sum = (op == PPLUS) ? 0 : 1;

    for (int a = args; a; a = cdr(a))
             if (op == PPLUS) sum += cons_cells[car(a)].id;
        else if (op == PTIMES) sum *= cons_cells[car(a)].id;

    int p = alloc();
    cons_cells[p].type = BT_NUM;
    cons_cells[p].id = sum;
    return p;
}

And it is called from within apply() via switch():

    switch (cons_cells[id].id) {
        case PPLUS:
        case PTIMES: return apply_plus_mult( id, args );
        case PNOT: return car(args) ? 0 : atom_true;
        ...

AND, after another look, it becomes apparent that much of the complexity of my apply_plus_mult() is attributable to "packing two different operations into one function".

Splitting the function into two separate, and even more trivial functions would make reading and checking even simpler. Follow KISS principles.

int store( int64_t val ) {
    int p = alloc();
    cons_cells[p].type = BT_NUM;
    cons_cells[p].id = val;
    return p;
}

int apply_plus( int args ) {
    int64_t v = 0;
    for (int a = args; a; a = cdr(a)) v += cons_cells[car(a)].id;
    return store( v );
}

int apply_mult( int args ) {
    int64_t v = 1;
    for (int a = args; a; a = cdr(a)) v *= cons_cells[car(a)].id;
    return store( v );
}

int apply( int id, int args ) {
    ...

    switch (cons_cells[id].id) {
        case PPLUS:  return apply_plus( args );
        case PTIMES: return apply_mult( args );
        case PNOT:  ...
\$\endgroup\$
8
  • 5
    \$\begingroup\$ The indentation problem is just due to SE's broken tab stops (every 4 columns, rather than every 8). But it's a salutary lesson: don't mix tabs and spaces for indentation. \$\endgroup\$ Commented Jun 14 at 7:10
  • 1
    \$\begingroup\$ Maybe drop the code into clang-format-configurator.site \$\endgroup\$
    – ggorlen
    Commented Jun 14 at 14:41
  • 1
    \$\begingroup\$ @ggorlen I'll take a look... Maybe you can campaign for SO/SE-CR to insist on code being "washed and rinsed" through that site before posting... Cheers! \$\endgroup\$
    – Fe2O3
    Commented Jun 14 at 22:17
  • 1
    \$\begingroup\$ @Fe2O3 That would be great. Or not allow one to post unformatted code. That would save everyone from a headache. \$\endgroup\$
    – Harith
    Commented Jun 15 at 0:43
  • 2
    \$\begingroup\$ @Harith Sometime in the past, the OP was directed to "always have a preamble comment block in this prescribed layout ahead of every function in your code." Result: hit-and-miss compliance, with copy/paste/not-changed reproductions leading to comments that are both overwhelmingly bulky and, too often, subtly incorrect/incomplete/out-of-date or even wildly inappropriate... "One Standard" may be appropriate if one has the resources, budget and longevity of the US military or Microsoft... Without that, "do the best you can" seems a target worth aiming for... :-) \$\endgroup\$
    – Fe2O3
    Commented Jun 15 at 1:31

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.