~brenns10/funlisp

74796a2bd9e3b4dd129d9b40fab17ca5958fd6bb — Stephen Brennan 3 years ago
initial commit (ish)
A  => .gitignore +10 -0
@@ 1,10 @@
syntax: glob
*~
dep
obj
bin
GTAGS
GRTAGS
GPATH
syntax: regexp
(.*/)?\#[^/]*\#$

A  => Makefile +189 -0
@@ 1,189 @@
#-------------------------------------------------------------------------------
#
# File:         Makefile
#
# Author:       Stephen Brennan
#
# Date Created: Friday, 17 July 2015
#
# Description:  Generic C Makefile
#
# This is a generic makefile, suitable for any C programming project.  It comes
# with several features:
# - Running tests, with Valgrind.
# - Generation of documentation through Doxygen.  You'll need to provide a
#   Doxyfile.
# - Code coverage reports via gcov.
# - Build configurations: debug, release, and coverage.
# - Automatic dependency generation, so you never need to update this file.
#
# To use:
# 1. You should organize your project like this:
#    src/
#    |--- code.c
#    |--- module-1.h
#    |--- module-1/code.c
#    \--- module-2/code.c
#    test/
#    \--- test-code.c
#    inc/
#    \--- public-header.h
# 2. Fill out the variables labelled CONFIGURATION.
# 3. Build configurations are: debug, release, coverage.  Run make like this:
#    make CFG=configuration target
#    The default target is release, so you can omit it normally.
# 4. Targets:
#    - all: makes your main project
#    - test: makes and runs tests
#    - doc: builds documentation
#    - cov: generates code coverage (MUST have CFG=coverage)
#    - clean: removes object and binary files
#    - clean_{doc,cov,dep}: removes documentation/coverage/dependencies
#
# This code is in the public domain, for anyone to use or modify in any way.
#
#-------------------------------------------------------------------------------

# --- CONFIGURATION: Definitely change this stuff!
# PROJECT_NAME - not actually used.  but what's your project's name?
PROJECT_NAME="funlisp"
# PROJECT_TYPE - staticlib, dynamiclib, executable
PROJECT_TYPE=executable
# PROJECT_MAIN - filename within your source directory that contains main()
PROJECT_MAIN=main.c
# TARGET - the name you want your target to have (bin/release/[whatgoeshere])
TARGET=main
# TEST_TARGET - the name you want your tests to have (probably test)
TEST_TARGET=
# STATIC_LIBS - path to any static libs you need.  you may need to make a rule
# to generate them from subprojects.  Leave this blank if you don't have any.
STATIC_LIBS=
# EXTRA_INCLUDES - folders that should also be include directories (say, for
# static libs?).  You can leave this blank if you don't have any.
EXTRA_INCLUDES=

# --- DIRECTORY STRUCTURE: This structure is highly recommended, but you can
# change it.  The most important thing is that *none* of these directories are
# subdirectories of each other.  They should be completely disjoint.  Also,
# being too creative with directories could seriously mess up gcov, which is a
# finicky beast.
SOURCE_DIR=src
TEST_DIR=test
INCLUDE_DIR=inc
OBJECT_DIR=obj
BINARY_DIR=bin
DEPENDENCY_DIR=dep
DOCUMENTATION_DIR=doc
COVERAGE_DIR=cov

# --- COMPILATION FLAGS: Things you may want/need to configure, but I've put
# them at sane defaults.
CC=gcc
#FLAGS=-Wall -Wextra -pedantic
FLAGS=
INC=-I$(INCLUDE_DIR) -I$(SOURCE_DIR) $(addprefix -I,$(EXTRA_INCLUDES))
CFLAGS=$(FLAGS) -std=c99 -fPIC $(INC) -c
LFLAGS=$(FLAGS) -ledit

# --- BUILD CONFIGURATIONS: Feel free to get creative with these if you'd like.
# The advantage here is that you can update variables (like compile flags) based
# on the build configuration.
CFG=release
ifeq ($(CFG),debug)
FLAGS += -g -DDEBUG
endif
ifeq ($(CFG),coverage)
CFLAGS += -fprofile-arcs -ftest-coverage
LFLAGS += -fprofile-arcs -lgcov
endif
ifneq ($(CFG),debug)
ifneq ($(CFG),release)
ifneq ($(CFG),coverage)
$(error Bad build configuration.  Choices are debug, release, coverage.)
endif
endif
endif

# --- FILENAME LISTS: (and other internal variables) You probably don't need to
# mess around with this stuff, unless you have a decent understanding of
# everything this Makefile does.
DIR_GUARD=@mkdir -p $(@D)
OBJECT_MAIN=$(OBJECT_DIR)/$(CFG)/$(SOURCE_DIR)/$(patsubst %.c,%.o,$(PROJECT_MAIN))

SOURCES=$(shell find $(SOURCE_DIR) -type f -name "*.c")
OBJECTS=$(patsubst $(SOURCE_DIR)/%.c,$(OBJECT_DIR)/$(CFG)/$(SOURCE_DIR)/%.o,$(SOURCES))

TEST_SOURCES=$(shell find $(TEST_DIR) -type f -name "*.c" 2> /dev/null)
TEST_OBJECTS=$(patsubst $(TEST_DIR)/%.c,$(OBJECT_DIR)/$(CFG)/$(TEST_DIR)/%.o,$(TEST_SOURCES))

DEPENDENCIES  = $(patsubst $(SOURCE_DIR)/%.c,$(DEPENDENCY_DIR)/$(SOURCE_DIR)/%.d,$(SOURCES))
DEPENDENCIES += $(patsubst $(TEST_DIR)/%.c,$(DEPENDENCY_DIR)/$(TEST_DIR)/%.d,$(TEST_SOURCES))

# --- GLOBAL TARGETS: You can probably adjust and augment these if you'd like.
.PHONY: all test clean clean_all clean_cov clean_doc

all: $(BINARY_DIR)/$(CFG)/$(TARGET)

test: $(BINARY_DIR)/$(CFG)/$(TEST_TARGET)
	valgrind $(BINARY_DIR)/$(CFG)/$(TEST_TARGET)

doc: $(SOURCES) $(TEST_SOURCES) Doxyfile
	doxygen

cov: $(BINARY_DIR)/$(CFG)/$(TEST_TARGET)
	@if [ "$(CFG)" != "coverage" ]; then \
	  echo "You must run 'make CFG=coverage coverage'."; \
	  exit 1; \
	fi
	rm -f coverage.info
	$(BINARY_DIR)/$(CFG)/$(TEST_TARGET)
	lcov -c -d $(OBJECT_DIR)/$(CFG) -b $(SOURCE_DIR) -o coverage.info
	lcov -e coverage.info "`pwd`/$(SOURCE_DIR)/*" -o coverage.info
	genhtml coverage.info -o $(COVERAGE_DIR)
	rm coverage.info

clean:
	rm -rf $(OBJECT_DIR)/$(CFG)/* $(BINARY_DIR)/$(CFG)/* $(SOURCE_DIR)/*.gch

clean_all: clean_cov clean_doc
	rm -rf $(OBJECT_DIR) $(BINARY_DIR) $(DEPENDENCY_DIR) $(SOURCE_DIR)/*.gch

clean_docs:
	rm -rf $(DOCUMENTATION_DIR)

clean_cov:
	rm -rf $(COVERAGE_DIR)

# RULE TO BUILD YOUR MAIN TARGET HERE: (you may have to edit this, but it it
# configurable).
$(BINARY_DIR)/$(CFG)/$(TARGET): $(OBJECTS) $(STATIC_LIBS)
	$(DIR_GUARD)
ifeq ($(PROJECT_TYPE),staticlib)
	ar rcs $@ $^
endif
ifeq ($(PROJECT_TYPE),dynamiclib)
	$(CC) -shared $(LFLAGS) $^ -o $@
endif
ifeq ($(PROJECT_TYPE),executable)
	$(CC) $(LFLAGS) $^ -o $@
endif

# RULE TO BUILD YOUR TEST TARGET HERE: (it's assumed that it's an executable)
$(BINARY_DIR)/$(CFG)/$(TEST_TARGET): $(filter-out $(OBJECT_MAIN),$(OBJECTS)) $(TEST_OBJECTS) $(STATIC_LIBS)
	$(DIR_GUARD)
	$(CC) $(LFLAGS) $^ -o $@

# --- Generic Compilation Command
$(OBJECT_DIR)/$(CFG)/%.o: %.c
	$(DIR_GUARD)
	$(CC) $(CFLAGS) $< -o $@

# --- Automatic Dependency Generation
$(DEPENDENCY_DIR)/%.d: %.c
	$(DIR_GUARD)
	$(CC) $(CFLAGS) -MM $< | sed -e 's!\(.*\)\.o:!$@ $(OBJECT_DIR)/$$(CFG)/$(<D)/\1.o:!' > $@

# --- Include Generated Dependencies
ifneq "$(MAKECMDGOALS)" "clean_all"
-include $(DEPENDENCIES)
endif

A  => src/charbuf.c +118 -0
@@ 1,118 @@
/*
 * charbuf.c: simple resizing character buffer for easy string manipulation
 *
 * Stephen Brennan <stephen@brennan.io>
 */

#include <stdlib.h>
#include <stdio.h>
#include <stdarg.h>
#include <wchar.h>
#include <string.h>

#include "charbuf.h"

/*
 * character buffer - for "narrow", one byte characters
 */

void cb_init(struct charbuf *obj, int capacity)
{
  // Initialization logic
  obj->buf = calloc(sizeof(char), (size_t)capacity);
  obj->buf[0] = '\0';
  obj->capacity = capacity;
  obj->length = 0;
}

struct charbuf *cb_create(int capacity)
{
  struct charbuf *obj = calloc(sizeof(struct charbuf), 1);
  cb_init(obj, capacity);
  return obj;
}

void cb_destroy(struct charbuf *obj)
{
  free(obj->buf);
  obj->buf = NULL;
}

void cb_delete(struct charbuf *obj) {
  cb_destroy(obj);
  free(obj);
}

/**
   @brief Ensure that the struct charbuf can fit a certain amount of characters.
   @param obj The struct charbuf to expand (if necessary).
   @param minsize The minimum size the struct charbuf should be able to fit.

   Note that minsize should include the NUL byte as part of the character count.
   Therefore, to ensure that the string "four" fits in the buffer, you would
   want to run `cb_expand_to_fit(obj, 5)` (assuming the buffer was empty).
 */
static void cb_expand_to_fit(struct charbuf *obj, int minsize)
{
  int newcapacity = obj->capacity;
  while (newcapacity < minsize) {
    newcapacity *= 2;
  }
  if (newcapacity != obj->capacity) {
    obj->buf = realloc(obj->buf, sizeof(char) * newcapacity);
    obj->capacity = newcapacity;
  }
}

void cb_concat(struct charbuf *obj, char *buf)
{
  int length = strlen(buf);
  cb_expand_to_fit(obj, obj->length + length + 1);
  strcpy(obj->buf + obj->length, buf);
  obj->length += length;
}

void cb_append(struct charbuf *obj, char next)
{
  cb_expand_to_fit(obj, obj->length + 2); // include new character + nul
  obj->buf[obj->length] = next;
  obj->length++;
  obj->buf[obj->length] = '\0';
}

void cb_trim(struct charbuf *obj)
{
  obj->buf = realloc(obj->buf, sizeof(char) * obj->length + 1);
  obj->capacity = obj->length + 1;
}

void cb_clear(struct charbuf *obj)
{
  obj->buf[0] = '\0';
  obj->length = 0;
}

void cb_vprintf(struct charbuf *obj, char *format, va_list va)
{
  va_list v2;
  int length;
  va_copy(v2, va);

  // Find the length of the formatted string.
  length = vsnprintf(NULL, 0, format, va);

  // Make sure we have enough room for everything.
  cb_expand_to_fit(obj, obj->length + length + 1);

  // Put the formatted string into the buffer.
  vsnprintf(obj->buf + obj->length, length + 1, format, v2);
  va_end(v2);
}

void cb_printf(struct charbuf *obj, char *format, ...)
{
  va_list va;
  va_start(va, format);
  cb_vprintf(obj, format, va);
  va_end(va);  // Have to va_stop() it when you're done using it.
}

A  => src/charbuf.h +100 -0
@@ 1,100 @@
/*
 * charbuf.h: simple resizing character buffer for easy string manipulation
 *
 * Stephen Brennan <stephen@brennan.io>
 */

#ifndef _CHARBUF_H
#define _CHARBUF_H

#include <stdarg.h>
#include <wchar.h>

/**
   @brief A character buffer utility that is easier to handle than a char*.

   This character buffer provides an interface for string processing that allows
   you to be efficient, while not needing to handle nearly as much of the
   allocations that are necessary.  It automatically expands as you add to it.
 */
struct charbuf {
  /**
     @brief Buffer pointer.
   */
  char *buf;
  /**
     @brief Allocated size of the buffer.
   */
  int capacity;
  /**
     @brief Length of the string in the buffer.
   */
  int length;
};

/**
   @brief Initialize a brand-new character buffer.

   A buffer of the given capacity is initialized, and given an empty string
   value.
   @param obj The struct charbuf to initialize.
   @param capacity Initial capacity of the buffer.
 */
void cb_init(struct charbuf *obj, int capacity);
/**
   @brief Allocate and initialize a brand-new character buffer.

   A buffer of the given capacity is initialized, and given an empty string
   value.  The struct charbuf struct is also allocated and the pointer returned.
   @param capacity Initial capacity of the buffer.
 */
struct charbuf *cb_create(int capacity);
/**
   @brief Deallocate the contents of the string buffer.
   @param obj The character buffer to deallocate.
 */
void cb_destroy(struct charbuf *obj);
/**
   @brief Deallocate the contents of, and delete the string buffer.
   @param obj The character buffer to delete.
 */
void cb_delete(struct charbuf *obj);

/**
   @brief Concat a string onto the end of the character buffer.
   @param obj The buffer to concat onto.
   @param str The string to concat.
 */
void cb_concat(struct charbuf *obj, char *str);
/**
   @brief Append a character onto the end of the character buffer.
   @param obj The buffer to append onto.
   @param next The character to append.
 */
void cb_append(struct charbuf *obj, char next);
/**
   @brief Reallocate the buffer to the exact size of the contained string.
   @param obj The buffer to reallocate.
 */
void cb_trim(struct charbuf *obj);
/**
   @brief Empty the buffer of its contents.
   @param obj The buffer to clear.
 */
void cb_clear(struct charbuf *obj);
/**
   @brief Format and print a string onto the end of a character buffer.
   @param obj The object to print onto.
   @param format The format string to print.
   @param ... The arguments to the format string.
 */
void cb_printf(struct charbuf *obj, char *format, ...);
/**
   @brief Format and print a string onto the struct charbuf using a va_list.
   @param obj The struct charbuf to print into.
   @param format The format string to print.
   @param va The vararg list.
 */
void cb_vprintf(struct charbuf *obj, char *format, va_list va);

#endif

A  => src/gc.c +64 -0
@@ 1,64 @@
/*
 * gc.c: mark and sweep garbage collection for funlisp
 *
 * Stephen Brennan <stephen@brennan.io>
 */
#include <assert.h>

#include "lisp.h"

void lisp_init(lisp_runtime *rt)
{
  rt->nil = type_list->new();
  rt->nil->mark = 0;
  rt->nil->type = type_list;
  rt->nil->next = NULL;
  rt->head = rt->nil;
  rt->tail = rt->nil;
  rb_init(&rt->rb, sizeof(lisp_value*), 16);
}

void lisp_destroy(lisp_runtime *rt)
{
  lisp_sweep(rt);
  rb_destroy(&rt->rb);
  lisp_free(rt->nil);
}

void lisp_mark(lisp_runtime *rt, lisp_value *v)
{
  rb_push_back(&rt->rb, &v);

  while (rt->rb.count > 0) {
    rb_pop_front(&rt->rb, &v);
    v->mark = GC_MARKED;
    struct iterator it = v->type->expand(v);
    while (it.has_next(&it)) {
      v = it.next(&it);
      if (v->mark == GC_NOMARK) {
        v->mark = GC_QUEUED;
        rb_push_back(&rt->rb, &v);
      }
    }
    it.close(&it);
  }
}

void lisp_sweep(lisp_runtime *rt)
{
  lisp_value *curr = rt->head;

  while (curr->next) {
    if (curr->next->mark != GC_MARKED) {
      lisp_value *tmp = curr->next->next;
      lisp_free(curr->next);
      curr->next = tmp;
    } else {
      curr->mark = GC_NOMARK;
      curr = curr->next;
    }
  }

  curr->mark = GC_NOMARK;
  rt->tail = curr;
}

A  => src/hashtable.c +461 -0
@@ 1,461 @@
/*
 * hashtable.c: a generic hash table with quadratic probing
 *
 * Designed for storing any size key and value. For the common case (when the
 * key and value are simply pointers), a set of _ptr functions are provided.
 *
 * Stephen Brennan <stephen@brennan.io>
 */

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

#include "iter.h"
#include "hashtable.h"

#define HTA_KEY_OFFSET 1
#define HASH_TABLE_INITIAL_SIZE 31
#define HASH_TABLE_MAX_LOAD_FACTOR 0.5

#define HT_EMPTY 0
#define HT_FULL 1
#define HT_GRAVE 2

#define HTA_MARK(t, i) ((int8_t*)t->table)[i]

#define nelem(x) (sizeof(x)/sizeof((x)[0]))

/*
 * private functions
 */

unsigned int ht_primes[] = {
  31, // 2^5
  61,
  127,
  257,
  509,
  1021,
  2053,
  4093,
  8191,
  16381,
  32771,
  65537,
  131071,
  262147,
  524287,
  1048573,
  2097143,
  4194301,
  8388617,
  16777213,
  33554467,
  67108859,
  134217757,
  268435459,
  536870909,
  1073741827,
  2147483647,
  4294967291 // 2^32
};

int binary_search(unsigned int *array, int len, unsigned int value)
{
  int lo = 0, hi = len, mid;
  while (lo < hi) {
    mid = (lo + hi) / 2;
    if (value <= array[mid]) {
      hi = mid;
    } else {
      lo = mid + 1;
    }
  }
  return lo;
}

/**
   @brief Returns the next hashtable size.

   @param current The current size of the hash table.
   @returns The next size in the sequence for hash tables.
 */
int ht_next_size(int current)
{
  int curridx = binary_search(ht_primes, nelem(ht_primes), current);
  return ht_primes[curridx + 1];
}

unsigned int item_size(const struct hashtable *obj)
{
  return HTA_KEY_OFFSET + obj->key_size + obj->value_size;
}

unsigned int convert_idx(const struct hashtable *obj, unsigned int orig)
{
  return orig * item_size(obj);
}

/**
   @brief Find the proper index for insertion into the table.
   @param obj Hash table object.
   @param key Key we're inserting.
 */
unsigned int ht_find_insert(const struct hashtable *obj, void *key)
{
  unsigned int index = obj->hash(key) % obj->allocated;
  unsigned int bufidx = convert_idx(obj, index);
  unsigned int j = 1;

  // Continue searching until we either find a non-full slot, or we find the key
  // we're trying to insert.
  // until (cell.mark != full || cell.key == key)
  // while (cell.mark == full && cell.key != key)
  while (HTA_MARK(obj, bufidx) == HT_FULL &&
         obj->equal(key, obj->table + bufidx + HTA_KEY_OFFSET) != 0) {
    // This is quadratic probing, but I'm avoiding squaring numbers:
    // j:     1, 3, 5, 7,  9, 11, ..
    // index: 0, 1, 4, 9, 16, 25, 36
    index = (index + j) % obj->allocated;
    j += 2;
    bufidx = convert_idx(obj, index);
  }

  return index;
}

/**
   @brief Find the proper index for retrieval from the table.
   @param obj Hash table object.
   @param key Key we're looking up.
 */
unsigned int ht_find_retrieve(const struct hashtable *obj, void *key)
{
  unsigned int index = obj->hash(key) % obj->allocated;
  unsigned int bufidx = convert_idx(obj, index);
  unsigned int j = 1;

  // Continue searching until we either find an empty slot, or we find the key
  // we're trying to insert.
  // until (cell.mark == empty || cell.key == key)
  // while (cell.mark != empty && cell.key != key)
  while (HTA_MARK(obj, bufidx) != HT_EMPTY &&
         obj->equal(key, obj->table + bufidx + HTA_KEY_OFFSET) != 0) {
    // This is quadratic probing, but I'm avoiding squaring numbers:
    // j:     1, 3, 5, 7,  9, 11, ..
    // index: 0, 1, 4, 9, 16, 25, 36
    index = (index + j) % obj->allocated;
    j += 2;
    bufidx = convert_idx(obj, index);
  }

  return index;
}

/**
   @brief Expand the hash table, adding increment to the capacity of the table.

   @param table The table to expand.
 */
void ht_resize(struct hashtable *table)
{
  void *old_table;
  unsigned int index, old_allocated, bufidx;

  // Step one: allocate new space for the table
  old_table = table->table;
  old_allocated = table->allocated;
  table->length = 0;
  table->allocated = ht_next_size(old_allocated);
  table->table = calloc(table->allocated, item_size(table));

  // Step two, add the old items to the new table.
  for (index = 0; index < old_allocated; index++) {
    bufidx = convert_idx(table, index);
    if (((int8_t*)old_table)[bufidx] == HT_FULL) {
      ht_insert(table, old_table + bufidx + HTA_KEY_OFFSET,
                 old_table + bufidx + HTA_KEY_OFFSET + table->value_size);
    }
  }

  // Step three: free old data.
  free(old_table);
}

/**
   @brief Return the load factor of a hash table.

   @param table The table to find the load factor of.
   @returns The load factor of the hash table.
 */
double ht_load_factor(struct hashtable *table)
{
  return ((double) table->length) / ((double) table->allocated);
}

/*
 * public functions
 */

void ht_init(struct hashtable *table, hash_t hash_func, comp_t equal,
              unsigned int key_size, unsigned int value_size)
{
  // Initialize values
  table->length = 0;
  table->allocated = HASH_TABLE_INITIAL_SIZE;
  table->key_size = key_size;
  table->value_size = value_size;
  table->hash = hash_func;
  table->equal = equal;

  // Allocate table
  table->table = calloc(HASH_TABLE_INITIAL_SIZE, item_size(table));
}

struct hashtable *ht_create(hash_t hash_func, comp_t equal,
                    unsigned int key_size, unsigned int value_size)
{
  // Allocate and create the table.
  struct hashtable *table;
  table = calloc(sizeof(struct hashtable), 1);
  ht_init(table, hash_func, equal, key_size, value_size);
  return table;
}

void ht_destroy(struct hashtable *table)
{
  free(table->table);
}

void ht_delete(struct hashtable *table)
{
  if (!table) {
    return;
  }

  ht_destroy(table);
  free(table);
}

void ht_insert(struct hashtable *table, void *key, void *value)
{
  unsigned int index, bufidx;
  if (ht_load_factor(table) > HASH_TABLE_MAX_LOAD_FACTOR) {
    ht_resize(table);
  }

  // First, probe for the key as if we're trying to return it.  If we find it,
  // we update the existing key.
  index = ht_find_retrieve(table, key);
  bufidx = convert_idx(table, index);
  if (HTA_MARK(table, bufidx) == HT_FULL) {
    memcpy(table->table + bufidx + HTA_KEY_OFFSET + table->key_size, value,
           table->value_size);
    return;
  }

  // If we don't find the key, then we find the first open slot or gravestone.
  index = ht_find_insert(table, key);
  bufidx = convert_idx(table, index);
  HTA_MARK(table, bufidx) = HT_FULL;
  memcpy(table->table + bufidx + HTA_KEY_OFFSET, key, table->key_size);
  memcpy(table->table + bufidx + HTA_KEY_OFFSET + table->key_size, value,
         table->value_size);
  table->length++;
}

void ht_insert_ptr(struct hashtable *table, void *key, void *value)
{
  ht_insert(table, &key, &value);
}

int ht_remove(struct hashtable *table, void *key)
{
  unsigned int index = ht_find_retrieve(table, key);
  unsigned int bufidx = convert_idx(table, index);

  // If the returned slot isn't full, that means we couldn't find it.
  if (HTA_MARK(table, bufidx) != HT_FULL) {
    return -1;
  }

  // Mark the slot with a "grave stone", indicating it is deleted.
  HTA_MARK(table, bufidx) = HT_GRAVE;
  table->length--;
  return 0;
}

int ht_remove_ptr(struct hashtable *table, void *key)
{
  ht_remove(table, &key);
}

void *ht_get(struct hashtable const *table, void *key)
{
  unsigned int index = ht_find_retrieve(table, key);
  unsigned int bufidx = convert_idx(table, index);

  // If the slot is not marked full, we didn't find the key.
  if (HTA_MARK(table, bufidx) != HT_FULL) {
    return NULL;
  }

  // Otherwise, return the value.
  return table->table + bufidx + HTA_KEY_OFFSET + table->key_size;
}

void *ht_get_ptr(struct hashtable const *table, void *key)
{
  void **result = ht_get(table, &key);
  return *result;
}

bool ht_contains(struct hashtable const *table, void *key)
{
  return ht_get(table, key) != NULL;
}

bool ht_contains_ptr(struct hashtable const *table, void *key)
{
  return ht_contains(table, &key);
}

unsigned int ht_string_hash(void *data)
{
  char *theString = *(char**)data;
  unsigned int hash = 0;

  while (theString && *theString != '\0' ) {
    hash = (hash << 5) - hash + *theString;
    theString++;
  }

  return hash;
}

int ht_string_comp(void *left, void *right)
{
  char **l = (char**)left, **r = (char**)right;
  return strcmp(*l,*r);
}

int ht_int_comp(void *left, void *right)
{
  int *l = (int*)left, *r = (int*)right;
  return *l - *r;
}

void ht_print(FILE* f, struct hashtable const *table, print_t key, print_t value,
               int full_mode)
{
  unsigned int i, bufidx;
  char *MARKS[] = {"EMPTY", " FULL", "GRAVE"};

  for (i = 0; i < table->allocated; i++) {
    bufidx = convert_idx(table, i);
    int8_t mark = HTA_MARK(table, bufidx);
    if (full_mode || mark == HT_FULL) {
      printf("[%04d|%05d|%s]:\n", i, bufidx, MARKS[mark]);
      if (mark == HT_FULL) {
        printf("  key: ");
        if (key) key(f, table->table + bufidx + HTA_KEY_OFFSET);
        printf("\n  value: ");
        if (value) value(f, table->table + bufidx + HTA_KEY_OFFSET + table->key_size);
        printf("\n");
      }
    }
  }
}

static void *ht_next(struct iterator *iter)
{
  struct hashtable *table = iter->ds;
  unsigned int bufidx;
  int8_t mark = HT_EMPTY;

  for (; mark != HT_FULL && iter->state_int < table->allocated; iter->state_int++) {
    bufidx = convert_idx(table, iter->state_int);
    mark = HTA_MARK(table, bufidx);
  }

  if (mark != HT_FULL) return NULL;

  iter->index++;

  if (!iter->state_ptr)
    return table->table + bufidx + HTA_KEY_OFFSET;
  else
    return table->table + bufidx + HTA_KEY_OFFSET + table->key_size;
}

static void *ht_next_ptr(struct iterator *iter)
{
  void **res = ht_next(iter);
  if (res == NULL)
    return NULL;
  return *res;
}

static bool ht_has_next(struct iterator *iter)
{
  struct hashtable *table = iter->ds;
  return iter->index < table->length;
}

struct iterator ht_iter_keys(struct hashtable *table)
{
  struct iterator it = {
    .ds = table,
    .index = 0,
    .state_int = 0,
    .state_ptr = NULL, /* when null, return keys, else return values */
    .has_next = ht_has_next,
    .next = ht_next,
    .close = iterator_close_noop,
  };
  return it;
}

struct iterator ht_iter_keys_ptr(struct hashtable *table)
{
  struct iterator it = {
    .ds = table,
    .index = 0,
    .state_int = 0,
    .state_ptr = NULL, /* when null, return keys, else return values */
    .has_next = ht_has_next,
    .next = ht_next_ptr,
    .close = iterator_close_noop,
  };
  return it;
}

struct iterator ht_iter_values(struct hashtable *table)
{
  struct iterator it = {
    .ds = table,
    .index = 0,
    .state_int = 0,
    .state_ptr = table, /* when null, return keys, else return values */
    .has_next = ht_has_next,
    .next = ht_next,
    .close = iterator_close_noop,
  };
  return it;
}

struct iterator ht_iter_values_ptr(struct hashtable *table)
{
  struct iterator it = {
    .ds = table,
    .index = 0,
    .state_int = 0,
    .state_ptr = table, /* when null, return keys, else return values */
    .has_next = ht_has_next,
    .next = ht_next_ptr,
    .close = iterator_close_noop,
  };
  return it;
}

A  => src/hashtable.h +123 -0
@@ 1,123 @@
/*
 * hashtable.h: hash table implementation
 *
 * Stephen Brennan <stephen@brennan.io>
 */
#include <stdio.h>

#include "iter.h"

#ifndef LIBSTEPHEN_HTA_H
#define LIBSTEPHEN_HTA_H

typedef unsigned int (*hash_t)(void *to_hash);

typedef int (*comp_t)(void *left, void *right);

typedef int (*print_t)(FILE *f, void *data);

struct hashtable
{
  unsigned int length;    /* number of items currently in the table */
  unsigned int allocated; /* number of items allocated */

  unsigned int key_size;
  unsigned int value_size;

  hash_t hash;
  comp_t equal;

  void *table;
};

/**
   @brief Initialize a hash table in memory already allocated.
   @param table A pointer to the table to initialize.
   @param hash_func A hash function for the table.
   @param equal A comparison function for void pointers
   @param key_size Size of keys.
   @param value_size Size of values.
 */
void ht_init(struct hashtable *table, hash_t hash_func, comp_t equal,
              unsigned int key_size, unsigned int value_size);
/**
   @brief Allocate and initialize a hash table.
   @param hash_func A function that takes one void* and returns a hash value
   generated from it.  It should be a good hash function.
   @param equal A comparison function for void pointers.
   @param key_size Size of keys.
   @param value_size Size of values.
   @returns A pointer to the new hash table.
 */
struct hashtable *ht_create(hash_t hash_func, comp_t equal,
                    unsigned int key_size, unsigned int value_size);
/**
   @brief Free any resources used by the hash table, but doesn't free the
   pointer.  Doesn't perform any actions on the data as it is deleted.

   If pointers are contained within the hash table, they are not freed. Use to
   specify a deletion action on the hash table.
   @param table The table to destroy.
 */
void ht_destroy(struct hashtable *table);
/**
   @brief Free the hash table and its resources.  No pointers contained in the
   table will be freed.
   @param table The table to free.
 */
void ht_delete(struct hashtable *table);

/**
   @brief Insert data into the hash table.

   Expands the hash table if the load factor is below a threshold.  If the key
   already exists in the table, then the function will overwrite it with the new
   data provided.
   @param table A pointer to the hash table.
   @param key The key to insert.
   @param value The value to insert at the key.
 */
void ht_insert(struct hashtable *table, void *key, void *value);
void ht_insert_ptr(struct hashtable *table, void *key, void *value);
/**
   @brief Remove the key, value pair stored in the hash table.

   This function does not call a deleter on the stored data.
   @param table A pointer to the hash table.
   @param key The key to delete.
   @return -1 on failure, 0 otherwise
 */
int ht_remove(struct hashtable *table, void *key);
int ht_remove_ptr(struct hashtable *table, void *key);
/**
   @brief Return the value associated with the key provided.
   @param table A pointer to the hash table.
   @param key The key whose value to retrieve.
   @returns The value associated the key, NULL if not found
 */
void *ht_get(struct hashtable const *table, void *key);
void *ht_get_ptr(struct hashtable const *table, void *key);
/**
   @brief Return true when a key is contained in the table.
   @param table A pointer to the hash table.
   @param key The key to search for.
   @returns Whether the key is present.
 */
bool ht_contains(struct hashtable const *table, void *key);
bool ht_contains_ptr(struct hashtable const *table, void *key);
/**
   @brief Return the hash of the data, interpreting it as a string.
   @param data The string to hash, assuming that the value contained is a char*.
   @returns The hash value of the string.
 */
unsigned int ht_string_hash(void *data);

int ht_string_comp(void *left, void *right);
int ht_int_comp(void *left, void *right);

struct iterator ht_iter_keys(struct hashtable *table);
struct iterator ht_iter_keys_ptr(struct hashtable *table);
struct iterator ht_iter_values(struct hashtable *table);
struct iterator ht_iter_values_ptr(struct hashtable *table);

#endif // LIBSTEPHEN_HTA_H

A  => src/iter.c +126 -0
@@ 1,126 @@
/*
 * iter.c: special iterators
 *
 * Stephen Brennan <stephen@brennan.io>
 */

#include <stdlib.h>
#include <stddef.h>
#include <stdint.h>

#include "iter.h"

void iterator_close_noop(struct iterator *iter) {}

static bool sv_has_next(struct iterator *iter)
{
  return iter->index == 0;
}

static void *sv_next(struct iterator *iter)
{
  iter->index++;
  return iter->ds;
}

struct iterator iterator_single_value(void *value)
{
  struct iterator it = {
    .ds=value,
    .index=0,
    .has_next=sv_has_next,
    .next=sv_next,
    .close=iterator_close_noop,
  };
  return it;
}

static bool cc_has_next(struct iterator *iter)
{
  struct iterator *its = iter->ds;
  intptr_t max_iterators = (intptr_t) iter->state_ptr;
  bool has_next;

  while (iter->state_int < max_iterators) {
    has_next = its[iter->state_int].has_next(&its[iter->state_int]);
    if (has_next) {
      return true;
    }

    its[iter->state_int].close(&its[iter->state_int]);
    iter->state_int++;
  }

  return false;
}

static void *cc_next(struct iterator *iter)
{
  struct iterator *its = iter->ds;
  void *result = its[iter->state_int].next(&its[iter->state_int]);
  if (result) {
    iter->index++;
  }
  return result;
}

static void cc_close(struct iterator *iter)
{
  free(iter->ds);
}

struct iterator iterator_concat(struct iterator *its, size_t n)
{
  struct iterator it = {
    .ds = its,
    .index = 0,
    .state_int = 0,
    .state_ptr = (void*) n,

    .has_next = cc_has_next,
    .next = cc_next,
    .close = cc_close,
  };
  return it;
}

struct iterator iterator_concat2(struct iterator left, struct iterator right)
{
  struct iterator *arr = calloc(sizeof(struct iterator), 2);
  arr[0] = left;
  arr[1] = right;
  return iterator_concat(arr, 2);
}

struct iterator iterator_concat3(struct iterator a, struct iterator b,
                                 struct iterator c)
{
  struct iterator *arr = calloc(sizeof(struct iterator), 3);
  arr[0] = a;
  arr[1] = b;
  arr[2] = c;
  return iterator_concat(arr, 3);
}

static void *empty_next(struct iterator *iter)
{
  (void)iter;
  return NULL;
}

static bool empty_has_next(struct iterator *iter)
{
  (void)iter;
  return false;
}

struct iterator iterator_empty()
{
  struct iterator it = {
    .index=0,
    .next=empty_next,
    .has_next=empty_has_next,
    .close=iterator_close_noop,
  };
  return it;
}

A  => src/iter.h +39 -0
@@ 1,39 @@
/*
 * iter.h: generic iterator interface
 *
 * Stephen Brennan <stephen@brennan.io>
 */
#include <stdbool.h>

#ifndef _ITER_H
#define _ITER_H

struct iterator {
  void *ds;        /* the container data structure */
  size_t index;    /* zero-based index for the iterator */
  int state_int;   /* some state variables that may help */
  void *state_ptr;

  /* do we have a next item? */
  bool (*has_next)(struct iterator *iter);

  /* return the next item (or null) */
  void *(*next)(struct iterator *iter);

  /* free resources held by the iterator */
  void (*close)(struct iterator *iter);
};

void iterator_close_noop(struct iterator *iter);
struct iterator iterator_empty();
struct iterator iterator_single_value(void *value);

/* concatenate n iterators. takes ownership of the *its pointer */
struct iterator iterator_concat(struct iterator *its, size_t n);

/* these use the above function */
struct iterator iterator_concat2(struct iterator left, struct iterator right);
struct iterator iterator_concat3(
  struct iterator a, struct iterator b, struct iterator c);

#endif

A  => src/lisp.h +148 -0
@@ 1,148 @@
/*
 * lisp.h: private lisp declarations
 *
 * Stephen Brennan <stephen@brennan.io>
 */

#ifndef _FUNLISP_H
#define _FUNLISP_H

#include <stdbool.h>
#include <stdio.h>

#include "iter.h"
#include "ringbuf.h"
#include "hashtable.h"

#define GC_NOMARK 'w'
#define GC_QUEUED 'g'
#define GC_MARKED 'b'

#define LISP_VALUE_HEAD             \
  struct {                          \
    struct lisp_type  *type;        \
    struct lisp_value *next;        \
    char mark;                      \
  }


// Type declarations.
typedef struct lisp_value {
  LISP_VALUE_HEAD;
} lisp_value;

// A lisp_runtime is NOT a lisp_value!
typedef struct {
  lisp_value *head;
  lisp_value *tail;

  // Some special values we don't want to lose track of
  lisp_value *nil;

  struct ringbuf rb;
} lisp_runtime;

// The below ARE lisp_values!
typedef struct lisp_scope {
  LISP_VALUE_HEAD;
  struct hashtable scope;
  struct lisp_scope *up;
} lisp_scope;

typedef struct {
  LISP_VALUE_HEAD;
  lisp_value *left;
  lisp_value *right;
} lisp_list;

typedef struct lisp_type {
  LISP_VALUE_HEAD;
  const char *name;
  void (*print)(FILE *f, lisp_value *value);
  lisp_value * (*new)(void);
  void (*free)(void *value);
  struct iterator (*expand)(lisp_value*);
  lisp_value * (*eval)(lisp_runtime *rt, lisp_scope *scope, lisp_value *value);
  lisp_value * (*call)(lisp_runtime *rt, lisp_scope *scope, lisp_value *callable, lisp_value *arg);
} lisp_type;

typedef struct {
  LISP_VALUE_HEAD;
  char *sym;
} lisp_symbol;

typedef struct {
  LISP_VALUE_HEAD;
  char *message;
} lisp_error;

typedef struct {
  LISP_VALUE_HEAD;
  int x;
} lisp_integer;

typedef struct {
  LISP_VALUE_HEAD;
  char *s;
} lisp_string;

typedef lisp_value * (*lisp_builtin_func)(lisp_runtime*, lisp_scope*,lisp_value*);
typedef struct {
  LISP_VALUE_HEAD;
  lisp_builtin_func call;
  char *name;
} lisp_builtin;

typedef struct {
  LISP_VALUE_HEAD;
  lisp_list *args;
  lisp_value *code;
  lisp_scope *closure;
} lisp_lambda;

// Interpreter stuff
void lisp_init(lisp_runtime *rt);
void lisp_mark(lisp_runtime *rt, lisp_value *v);
void lisp_sweep(lisp_runtime *rt);
void lisp_destroy(lisp_runtime *rt);

// Shortcuts for type operations.
void lisp_print(FILE *f, lisp_value *value);
void lisp_free(lisp_value *value);
lisp_value *lisp_eval(lisp_runtime *rt, lisp_scope *scope, lisp_value *value);
lisp_value *lisp_call(lisp_runtime *rt, lisp_scope *scope, lisp_value *callable,
                      lisp_value *arguments);
lisp_value *lisp_new(lisp_runtime *rt, lisp_type *typ);

// Shortcuts for creation of objects
lisp_symbol *lisp_symbol_new(lisp_runtime *rt, char *string);
lisp_error *lisp_error_new(lisp_runtime *rt, char *message);
lisp_builtin *lisp_builtin_new(lisp_runtime *rt, char *name,
                               lisp_builtin_func call);
lisp_value *lisp_nil_new(lisp_runtime *rt);

// Helper functions
void lisp_scope_bind(lisp_scope *scope, lisp_symbol *symbol, lisp_value *value);
lisp_value *lisp_scope_lookup(lisp_runtime *rt, lisp_scope *scope,
                              lisp_symbol *symbol);
void lisp_scope_add_builtin(lisp_runtime *rt, lisp_scope *scope, char *name, lisp_builtin_func call);
void lisp_scope_populate_builtins(lisp_runtime *rt, lisp_scope *scope);
lisp_value *lisp_eval_list(lisp_runtime *rt, lisp_scope *scope, lisp_value *list);
lisp_value *lisp_parse(lisp_runtime *rt, char *input);
bool lisp_get_args(lisp_list *list, char *format, ...);
lisp_value *lisp_quote(lisp_runtime *rt, lisp_value *value);
// List functions
int lisp_list_length(lisp_list *list);
bool lisp_nil_p(lisp_value *l);

extern lisp_type *type_type;
extern lisp_type *type_scope;
extern lisp_type *type_list;
extern lisp_type *type_symbol;
extern lisp_type *type_error;
extern lisp_type *type_integer;
extern lisp_type *type_string;
extern lisp_type *type_builtin;
extern lisp_type *type_lambda;

#endif

A  => src/main.c +31 -0
@@ 1,31 @@
#include <editline/readline.h>
#include <stdio.h>
#include <stdlib.h>

#include "lisp.h"

int main(int argc, char **argv)
{
  lisp_runtime rt;
  lisp_init(&rt);
  lisp_scope *scope = (lisp_scope*)lisp_new(&rt, type_scope);
  lisp_scope_populate_builtins(&rt, scope);

  while (true) {
    char *input = readline("> ");
    if (input == NULL) {
      break;
    }
    lisp_value *value = lisp_parse(&rt, input);
    add_history(input);
    free(input);
    lisp_value *result = lisp_eval(&rt, scope, value);
    lisp_print(stdout, result);
    fprintf(stdout, "\n");
    lisp_mark(&rt, (lisp_value*)scope);
    lisp_sweep(&rt);
  }

  lisp_destroy(&rt);
  return 0;
}

A  => src/parse.c +163 -0
@@ 1,163 @@
/*
 * parse.c: recursive descent parser for funlisp
 *
 * Stephen Brennan <stephen@brennan.io>
 */

#include <stdlib.h>
#include <stddef.h>
#include <assert.h>
#include <ctype.h>
#include <string.h>

#include "lisp.h"
#include "charbuf.h"

typedef struct {
  lisp_value *result;
  int index;
} result;

result lisp_parse_value(lisp_runtime *rt, char *input, int index);

result lisp_parse_integer(lisp_runtime *rt, char *input, int index)
{
  //printf("lisp_parse_integer(%s, %d)\n", input, index);
  int n;
  lisp_integer *v = (lisp_integer*)lisp_new(rt, type_integer);
  sscanf(input + index, "%d%n", &v->x, &n);
  return (result){(lisp_value*)v, index + n};
}

char lisp_escape(char escape)
{
  switch (escape) {
  case 'a':
    return '\a';
  case 'b':
    return '\b';
  case 'f':
    return '\f';
  case 'n':
    return '\n';
  case 'r':
    return '\b';
  case 't':
    return '\t';
  case 'v':
    return '\v';
  default:
    return escape;
  }
}

result lisp_parse_string(lisp_runtime *rt, char *input, int index)
{
  int i = index + 1;
  struct charbuf cb;
  cb_init(&cb, 16);
  while (input[i] && input[i] != '"') {
    if (input[i] == '\\') {
      cb_append(&cb, lisp_escape(input[++i]));
    } else {
      cb_append(&cb, input[i]);
    }
    i++;
  }
  cb_trim(&cb);
  lisp_string *str = (lisp_string*)lisp_new(rt, type_string);
  str->s = cb.buf;
  return (result){(lisp_value*)str, ++i};
}

result lisp_parse_list_or_sexp(lisp_runtime *rt, char *input, int index)
{
  while (isspace(input[index])) {index++;}
  if (input[index] == ')') {
    return (result){(lisp_value*)lisp_nil_new(rt), index + 1};
  }

  result r = lisp_parse_value(rt, input, index);
  index = r.index;
  lisp_list *rv = (lisp_list*)lisp_new(rt, type_list);
  rv->left = r.result;
  lisp_list *l = rv;

  while (true) {
    while (isspace(input[index])) {
      index++;
    }

    if (input[index] == '.') {
      index++;
      result r = lisp_parse_value(rt, input, index);
      index = r.index;
      l->right = r.result;
      return (result){(lisp_value*)rv, index};
    } else if (input[index] == ')') {
      index++;
      l->right = lisp_nil_new(rt);
      return (result){(lisp_value*)rv, index};
    } else {
      result r = lisp_parse_value(rt, input, index);
      l->right = lisp_new(rt, type_list);
      l = (lisp_list*)l->right;
      l->left = r.result;
      index = r.index;
    }
  }
}

result lisp_parse_symbol(lisp_runtime *rt, char *input, int index)
{
  int n = 0;
  while (input[index + n] && !isspace(input[index + n]) &&
         input[index + n] != ')' && input[index + n] != '.' &&
         input[index + n] != '\'') {
    n++;
  }
  lisp_symbol *s = (lisp_symbol*)lisp_new(rt, type_symbol);
  s->sym = malloc(n + 1);
  strncpy(s->sym, input + index, n);
  s->sym[n] = '\0';
  return (result){(lisp_value*)s, index + n};
}

result lisp_parse_quote(lisp_runtime *rt, char *input, int index)
{
  result r = lisp_parse_value(rt, input, index + 1);
  r.result = lisp_quote(rt, r.result);
  return r;
}

result lisp_parse_value(lisp_runtime *rt, char *input, int index)
{
  while (isspace(input[index])) {
    index++;
  }

  if (input[index] == '"') {
    return lisp_parse_string(rt, input, index);
  }
  if (input[index] == '\0') {
    return (result){NULL, index};
  }
  if (input[index] == ')') {
    return (result){lisp_nil_new(rt), index + 1};
  }
  if (input[index] == '(') {
    return lisp_parse_list_or_sexp(rt, input, index + 1);
  }
  if (input[index] == '\'') {
    return lisp_parse_quote(rt, input, index);
  }
  if (isdigit(input[index])) {
    return lisp_parse_integer(rt, input, index);
  }
  return lisp_parse_symbol(rt, input, index);
}

lisp_value *lisp_parse(lisp_runtime *rt, char *input)
{
  return lisp_parse_value(rt, input, 0).result;
}

A  => src/ringbuf.c +73 -0
@@ 1,73 @@
#include "ringbuf.h"

#include <stdlib.h>
#include <string.h>

void rb_init(struct ringbuf *rb, int dsize, int init)
{
  rb->dsize = dsize;
  rb->nalloc = init;
  rb->start = 0;
  rb->count = 0;
  rb->data = calloc(dsize, init);
}

void rb_destroy(struct ringbuf *rb)
{
  free(rb->data);
}

void rb_grow(struct ringbuf *rb)
{
  int oldalloc = rb->nalloc;
  rb->nalloc *= 2;
  rb->data = realloc(rb->data, rb->nalloc * rb->dsize);

  for (int i = 0; i < rb->count; i++) {
    int oldindex = (rb->start + i) % oldalloc;
    int newindex = (rb->start + i) % rb->nalloc;
    if (oldindex != newindex) {
      memcpy(rb->data + newindex * rb->dsize,
             rb->data + oldindex * rb->dsize, rb->nalloc);
    }
  }
}

void rb_push_front(struct ringbuf *rb, void *src)
{
  if (rb->count >= rb->nalloc) {
    rb_grow(rb);
  }

  // ensure the new start index is still positive
  int newstart = (rb->start + rb->nalloc - 1) % rb->nalloc;
  rb->start = newstart;
  memcpy(rb->data + rb->start * rb->dsize, src, rb->dsize);
  rb->count++;
}

void rb_pop_front(struct ringbuf *rb, void *dst)
{
  int newstart = (rb->start + 1) % rb->nalloc;
  memcpy(dst, rb->data + rb->start * rb->dsize, rb->dsize);
  rb->start = newstart;
  rb->count--;
}

void rb_push_back(struct ringbuf *rb, void *src)
{
  if (rb->count >= rb->nalloc) {
    rb_grow(rb);
  }

  int index = (rb->start + rb->count) % rb->nalloc;
  memcpy(rb->data + index * rb->dsize, src, rb->dsize);
  rb->count++;
}

void rb_pop_back(struct ringbuf *rb, void *dst)
{
  int index = (rb->start + rb->count - 1) % rb->nalloc;
  memcpy(dst, rb->data + index * rb->dsize, rb->dsize);
  rb->count--;
}

A  => src/ringbuf.h +75 -0
@@ 1,75 @@
/*
 * ringbuf.h: expandable, circular buffer
 *
 * Stephen Brennan <stephen@brennan.io>
 */

#ifndef _RINGBUF_H
#define _RINGBUF_H

/**
   A ring buffer data structure. This buffer can be inserted into and removed
   from at either end in constant time, except for memory allocations which may
   have to occur to expand the buffer. However these always double the buffer
   size, which means the number of allocations is logarithmic with respect to
   the number of insertions.
 */
struct ringbuf {

  void *data;
  int dsize;

  int nalloc;
  int start;
  int count;

};

/**
   @brief Initialize a ring buffer.
   @param rb Pointer to a ring buffer struct.
   @param dsize Size of data type to store in ring buffer.
   @param init Initial amount of space to allocate.
 */
void rb_init(struct ringbuf *rb, int dsize, int init);
/**
   @brief Free all resources held by the ring buffer.
   @param rb Pointer to the ring buffer struct.
 */
void rb_destroy(struct ringbuf *rb);
/**
   @brief Add an item to the front of the ring buffer.  May trigger expansion.
   @param src Area of memory to read from.
 */
void rb_push_front(struct ringbuf *rb, void *src);
/**
   @brief Remove an item from the front of the ring buffer.
   @param dst Area of memory to write resulting data to.

   Note that behavior is unbefined if you decide to pop from an empty buffer.
 */
void rb_pop_front(struct ringbuf *rb, void *dst);
/**
   @brief Add an item to the end of the ring buffer.  May trigger expansion.
   @param src Area of memory to read from.
*/
void rb_push_back(struct ringbuf *rb, void *src);
/**
   @brief Remove an item from the end of the ring buffer.
   @param dst Area of memory to write resulting data to.

   Note that behavior is undefined if you decide to pop from an empty buffer.
*/
void rb_pop_back(struct ringbuf *rb, void *dst);

/**
   @brief Expand a ring buffer (by doubling its size).
   @param rb Pointer to ring buffer.

   Note that this is mostly an internal function, and is exposed in the header
   for testing purposes. No guarantee is made that its interface will stay the
   same, or that it will continue to exist.
 */
void rb_grow(struct ringbuf *rb);

#endif

A  => src/types.c +613 -0
@@ 1,613 @@
/*
 * types.c: language types for funlisp
 *
 * Stephen Brennan <stephen@brennan.io>
 */
#include <assert.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>

#include "lisp.h"
#include "iter.h"
#include "hashtable.h"

/*
 * Some generic functions for types
 */

static lisp_value *eval_error(lisp_runtime *rt, lisp_scope *s, lisp_value *v)
{
  (void)s;
  (void)v;
  return (lisp_value*) lisp_error_new(rt, "cannot evaluate this object");
}

static lisp_value *eval_same(lisp_runtime *rt, lisp_scope *s, lisp_value *v)
{
  (void)rt;
  (void)s;
  return v;
}

static lisp_value *call_error(lisp_runtime *rt, lisp_scope *s, lisp_value *c,
                              lisp_value *v)
{
  (void)s;
  (void)c;
  (void)v;
  return (lisp_value*) lisp_error_new(rt, "not callable!");
}

static lisp_value *call_same(lisp_runtime *rt, lisp_scope *s, lisp_value *c,
                             lisp_value *v)
{
  (void)rt;
  (void)s;
  (void)v;
  return c;
}

static bool has_next_index_lt_state(struct iterator *iter)
{
  return iter->index < iter->state_int;
}

/*
 * type
 */

static void type_print(FILE *f, lisp_value *v);
static lisp_value *type_new(void);

static lisp_type type_type_obj = {
  .type=&type_type_obj,
  .name="type",
  .print=type_print,
  .new=type_new,
  .eval=eval_error,
  .free=free,
  .call=call_error,
  .expand=iterator_empty,
};
lisp_type *type_type = &type_type_obj;

static void type_print(FILE *f, lisp_value *v)
{
  lisp_type *value = (lisp_type*) v;
  fprintf(f, "%s", value->name);
}

static lisp_value *type_new(void)
{
  lisp_type *type = malloc(sizeof(lisp_type));
  return (lisp_value*)type;
}

/*
 * scope
 */

static void scope_print(FILE *f, lisp_value*v);
static lisp_value *scope_new(void);
static void scope_free(void *v);
static struct iterator scope_expand(lisp_value *);

static lisp_type type_scope_obj = {
  .type=&type_type_obj,
  .name="scope",
  .print=scope_print,
  .new=scope_new,
  .eval=eval_error,
  .free=scope_free,
  .call=call_error,
  .expand=scope_expand,
};
lisp_type *type_scope = &type_scope_obj;

static unsigned int symbol_hash(void *symbol)
{
  lisp_symbol **sym = symbol;
  return ht_string_hash(&(*sym)->sym);
}

static int symbol_compare(void *left, void *right)
{
  lisp_symbol **sym1 = left;
  lisp_symbol **sym2 = right;
  return strcmp((*sym1)->sym, (*sym2)->sym);
}

static lisp_value *scope_new(void)
{
  lisp_scope *scope = malloc(sizeof(lisp_scope));
  scope->up = NULL;
  ht_init(&scope->scope, symbol_hash, symbol_compare, sizeof(void*), sizeof(void*));
  return (lisp_value*)scope;
}

static void scope_free(void *v)
{
  lisp_scope *scope = (lisp_scope*) v;
  ht_destroy(&scope->scope);
  free(scope);
}

static void scope_print(FILE *f, lisp_value *v)
{
  lisp_scope *scope = (lisp_scope*) v;
  struct iterator it = ht_iter_keys_ptr(&scope->scope);
  fprintf(f, "(scope:");
  while (it.has_next(&it)) {
    lisp_value *key = it.next(&it);
    lisp_value *value = ht_get_ptr(&scope->scope, key);
    fprintf(f, " ");
    lisp_print(f, key);
    fprintf(f, ": ");
    lisp_print(f, value);
  }
  fprintf(f, ")");
}

static struct iterator scope_expand(lisp_value *v)
{
  lisp_scope *scope = (lisp_scope *) v;
  if (scope->up) {
    return iterator_concat3(
      iterator_single_value(&scope->up),
      ht_iter_keys_ptr(&scope->scope),
      ht_iter_values_ptr(&scope->scope)
    );
  } else {
    return iterator_concat2(
      ht_iter_keys_ptr(&scope->scope),
      ht_iter_values_ptr(&scope->scope)
    );
  }
}

/*
 * list
 */

static void list_print(FILE *f, lisp_value *v);
static lisp_value *list_new(void);
static lisp_value *list_eval(lisp_runtime*, lisp_scope*, lisp_value*);
static struct iterator list_expand(lisp_value*);

static lisp_type type_list_obj = {
  .type=&type_type_obj,
  .name="list",
  .print=list_print,
  .new=list_new,
  .eval=list_eval,
  .free=free,
  .call=call_error,
  .expand=list_expand,
};
lisp_type *type_list = &type_list_obj;

static lisp_value *list_eval(lisp_runtime *rt, lisp_scope *scope, lisp_value *v)
{
  lisp_list *list = (lisp_list*) v;
  if (list->right->type != type_list) {
    return (lisp_value*) lisp_error_new(rt, "bad function call syntax");
  }
  lisp_value *callable = lisp_eval(rt, scope, list->left);
  lisp_value *rv = lisp_call(rt, scope, callable, list->right);
  return rv;
}

static void list_print_internal(FILE *f, lisp_list *list)
{
  if (lisp_nil_p((lisp_value*)list)) {
    return;
  }
  lisp_print(f, list->left);
  if (list->right->type != type_list) {
    fprintf(f, " . ");
    lisp_print(f, list->right);
    return;
  } else if (!lisp_nil_p((lisp_value*)list)) {
    fprintf(f, " ");
    list_print_internal(f, (lisp_list*)list->right);
  }
}

static void list_print(FILE *f, lisp_value *v)
{
  fprintf(f, "(");
  list_print_internal(f, (lisp_list*)v);
  fprintf(f, ")");
}

static lisp_value *list_new(void)
{
  lisp_list *list = malloc(sizeof(lisp_list));
  list->left = NULL;
  list->right = NULL;
  return (lisp_value*) list;
}

bool lisp_nil_p(lisp_value *l)
{
  return (l->type == type_list) &&
    (((lisp_list*)l)->right == NULL) &&
    (((lisp_list*)l)->left == NULL);
}

static void *list_expand_next(struct iterator *it)
{
  lisp_list *l = (lisp_list*) it->ds;
  it->index++;
  switch (it->index) {
  case 1:
    return l->left;
  case 2:
    return l->right;
  default:
    return NULL;
  }
}

static bool list_has_next(struct iterator *it)
{
  lisp_value *l = (lisp_value*)it->ds;
  if (lisp_nil_p(l)) {
    return false;
  } else {
    return it->index < it->state_int;
  }
}

static struct iterator list_expand(lisp_value *v)
{
  struct iterator it = {
    .ds=v,
    .state_int=2,
    .index=0,
    .next=list_expand_next,
    .has_next=list_has_next,
    .close=iterator_close_noop,
  };
  return it;
}

/*
 * symbol
 */

static void symbol_print(FILE *f, lisp_value *v);
static lisp_value *symbol_new(void);
static lisp_value *symbol_eval(lisp_runtime*, lisp_scope*, lisp_value*);
static void symbol_free(void *v);
static struct iterator symbol_expand(lisp_value*v);

static lisp_type type_symbol_obj = {
  .type=&type_type_obj,
  .name="symbol",
  .print=symbol_print,
  .new=symbol_new,
  .eval=symbol_eval,
  .free=symbol_free,
  .call=call_error,
  .expand=iterator_empty,
};
lisp_type *type_symbol = &type_symbol_obj;

static void symbol_print(FILE *f, lisp_value *v)
{
  lisp_symbol *symbol = (lisp_symbol*) v;
  fprintf(f, "%s", symbol->sym);
}

static lisp_value *symbol_new(void)
{
  lisp_symbol *symbol = malloc(sizeof(lisp_symbol));
  symbol->sym = NULL;
  return (lisp_value*)symbol;
}

static lisp_value *symbol_eval(lisp_runtime *rt, lisp_scope *scope,
                               lisp_value *value)
{
  (void)rt;
  lisp_symbol *symbol = (lisp_symbol*) value;
  return lisp_scope_lookup(rt, scope, symbol);
}

static void symbol_free(void *v)
{
  lisp_symbol *symbol = (lisp_symbol*) v;
  free(symbol->sym);
  free(symbol);
}

/*
 * error
 */

static void error_print(FILE *f, lisp_value *v);
static lisp_value *error_new(void);
static void error_free(void *v);

static lisp_type type_error_obj = {
  .type=&type_type_obj,
  .name="error",
  .print=error_print,
  .new=error_new,
  .eval=eval_same,
  .free=error_free,
  .call=call_same,
  .expand=iterator_empty,
};
lisp_type *type_error = &type_error_obj;

static void error_print(FILE *f, lisp_value *v)
{
  lisp_error *error = (lisp_error*) v;
  fprintf(f, "error: %s", error->message);
}

static lisp_value *error_new(void)
{
  lisp_error *error = malloc(sizeof(lisp_error));
  error->type = type_error;
  error->message = NULL;
  return (lisp_value*)error;
}

static void error_free(void *v)
{
  lisp_error *error = (lisp_error*) v;
  free(error->message);
  free(error);
}

/*
 * integer
 */

static void integer_print(FILE *f, lisp_value *v);
static lisp_value *integer_new(void);

static lisp_type type_integer_obj = {
  .type=&type_type_obj,
  .name="integer",
  .print=integer_print,
  .new=integer_new,
  .eval=eval_same,
  .free=free,
  .call=call_error,
  .expand=iterator_empty,
};
lisp_type *type_integer = &type_integer_obj;

static void integer_print(FILE *f, lisp_value *v)
{
  lisp_integer *integer = (lisp_integer*) v;
  fprintf(f, "%d", integer->x);
}

static lisp_value *integer_new(void)
{
  lisp_integer *integer = malloc(sizeof(lisp_integer));
  integer->x = 0;
  return (lisp_value*)integer;
}

// string

static void string_print(FILE *f, lisp_value *v);
static lisp_value *string_new(void);
static void string_free(void *v);

static lisp_type type_string_obj = {
  .type=&type_type_obj,
  .name="string",
  .print=string_print,
  .new=string_new,
  .eval=eval_same,
  .free=string_free,
  .call=call_error,
  .expand=iterator_empty,
};
lisp_type *type_string = &type_string_obj;

static void string_print(FILE *f, lisp_value *v)
{
  lisp_string *str = (lisp_string*) v;
  fprintf(f, "%s", str->s);
}

static lisp_value *string_new(void)
{
  lisp_string *str = malloc(sizeof(lisp_string));
  str->s = NULL;
  return (lisp_value*)str;
}

static void string_free(void *v)
{
  lisp_string *str = (lisp_string*) v;
  free(str->s);
  free(str);
}

/*
 * builtin
 */

static void builtin_print(FILE *f, lisp_value *v);
static lisp_value *builtin_new(void);
static lisp_value *builtin_call(lisp_runtime *rt, lisp_scope *scope,
                                lisp_value *c, lisp_value *arguments);

static lisp_type type_builtin_obj = {
  .type=&type_type_obj,
  .name="builtin",
  .print=builtin_print,
  .new=builtin_new,
  .eval=eval_error,
  .free=free,
  .call=builtin_call,
  .expand=iterator_empty,
};
lisp_type *type_builtin = &type_builtin_obj;

static void builtin_print(FILE *f, lisp_value *v)
{
  lisp_builtin *builtin = (lisp_builtin*) v;
  fprintf(f, "<builtin function %s>", builtin->name);
}

static lisp_value *builtin_new()
{
  lisp_builtin *builtin = malloc(sizeof(lisp_builtin));
  builtin->call = NULL;
  builtin->name = NULL;
  return (lisp_value*) builtin;
}

static lisp_value *builtin_call(lisp_runtime *rt, lisp_scope *scope,
                                lisp_value *c, lisp_value *arguments)
{
  lisp_builtin *builtin = (lisp_builtin*) c;
  return builtin->call(rt, scope, arguments);
}

/*
 * lambda
 */

static void lambda_print(FILE *f, lisp_value *v);
static lisp_value *lambda_new(void);
static lisp_value *lambda_call(lisp_runtime *rt, lisp_scope *scope,
                               lisp_value *c, lisp_value *arguments);
static struct iterator lambda_expand(lisp_value *v);

static lisp_type type_lambda_obj = {
  .type=&type_type_obj,
  .name="lambda",
  .print=lambda_print,
  .new=lambda_new,
  .eval=eval_error,
  .free=free,
  .call=lambda_call,
  .expand=lambda_expand,
};
lisp_type *type_lambda = &type_lambda_obj;

static void lambda_print(FILE *f, lisp_value *v)
{
  (void)v;
  fprintf(f, "<lambda function>");
}

static lisp_value *lambda_new()
{
  lisp_lambda *lambda = malloc(sizeof(lisp_lambda));
  lambda->args = NULL;
  lambda->code = NULL;
  return (lisp_value*) lambda;
}

static lisp_value *lambda_call(lisp_runtime *rt, lisp_scope *scope,
                               lisp_value *c, lisp_value *arguments)
{
  lisp_lambda *lambda = (lisp_lambda*) c;
  lisp_list *argvalues = (lisp_list*)lisp_eval_list(rt, scope, arguments);
  lisp_scope *inner = (lisp_scope*)lisp_new(rt, type_scope);
  inner->up = lambda->closure;

  lisp_list *it1 = lambda->args, *it2 = argvalues;
  while (!lisp_nil_p((lisp_value*)it1) && !lisp_nil_p((lisp_value*)it2)) {
    lisp_scope_bind(inner, (lisp_symbol*) it1->left, it2->left);
    it1 = (lisp_list*) it1->right;
    it2 = (lisp_list*) it2->right;
  }

  if (!lisp_nil_p((lisp_value*)it1)) {
    return (lisp_value*) lisp_error_new(rt, "not enough arguments");
  }
  if (!lisp_nil_p((lisp_value*)it2)) {
    return (lisp_value*) lisp_error_new(rt, "too many arguments");
  }

  return lisp_eval(rt, inner, lambda->code);
}

static void *lambda_expand_next(struct iterator *it)
{
  lisp_lambda *l = (lisp_lambda*)it->ds;
  it->index++;
  switch (it->index) {
  case 1:
    return l->args;
  case 2:
    return l->code;
  case 3:
    return l->closure;
  default:
    return NULL;
  }
}

static struct iterator lambda_expand(lisp_value *v)
{
  struct iterator it = {
    .ds=v,
    .state_int=3,
    .index=0,
    .next=lambda_expand_next,
    .has_next=has_next_index_lt_state,
    .close=iterator_close_noop,
  };
  return it;
}

/*
 * some shortcuts for accessing these type methods on lisp values
 */

void lisp_print(FILE *f, lisp_value *value)
{
  value->type->print(f, value);
}

void lisp_free(lisp_value *value)
{
  value->type->free(value);
}

lisp_value *lisp_eval(lisp_runtime *rt, lisp_scope *scope, lisp_value *value)
{
  return value->type->eval(rt, scope, value);
}

lisp_value *lisp_call(lisp_runtime *rt, lisp_scope *scope,
                      lisp_value *callable, lisp_value *args)
{
  if (callable->type == type_error) {
    return callable;
  }

  return callable->type->call(rt, scope, callable, args);
}

lisp_value *lisp_new(lisp_runtime *rt, lisp_type *typ)
{
  lisp_value *new = typ->new();
  new->type = typ;
  new->next = NULL;
  new->mark = GC_NOMARK;
  if (rt->head == NULL) {
    rt->head = new;
    rt->tail = new;
  } else {
    rt->tail->next = new;
    rt->tail = new;
  }
  return new;
}

A  => src/util.c +628 -0
@@ 1,628 @@
/*
 * util.c: utilites and builtins for funlisp
 *
 * Stephen Brennan <stephen@brennan.io>
 */

#include <assert.h>
#include <stdarg.h>
#include <string.h>
#include <stdlib.h>

#include "lisp.h"
#include "hashtable.h"

static lisp_list *lisp_new_pair_list(lisp_runtime *rt, lisp_value *one, lisp_value *two)
{
  lisp_list *first_node = (lisp_list*) lisp_new(rt, type_list);
  lisp_list *second_node = (lisp_list*) lisp_new(rt, type_list);
  first_node->left = one;
  first_node->right = (lisp_value*) second_node;
  second_node->left = two;
  second_node->right = lisp_nil_new(rt);
  return first_node;
}

void lisp_scope_bind(lisp_scope *scope, lisp_symbol *symbol, lisp_value *value)
{
  ht_insert_ptr(&scope->scope, symbol, value);
}

lisp_value *lisp_scope_lookup(lisp_runtime *rt, lisp_scope *scope,
                              lisp_symbol *symbol)
{
  lisp_value *v = ht_get_ptr(&scope->scope, symbol);
  if (!v) {
    if (scope->up) {
      return lisp_scope_lookup(rt, scope->up, symbol);
    } else {
      return (lisp_value*)lisp_error_new(rt, "symbol not found in scope");
    }
  } else {
    return v;
  }
}

void lisp_scope_add_builtin(lisp_runtime *rt, lisp_scope *scope, char *name,
                            lisp_builtin_func call)
{
  lisp_symbol *symbol = lisp_symbol_new(rt, name);
  lisp_builtin *builtin = lisp_builtin_new(rt, name, call);
  lisp_scope_bind(scope, symbol, (lisp_value*)builtin);
}

void lisp_scope_replace_or_insert(lisp_scope *scope, lisp_symbol *key, lisp_value *value)
{
  lisp_scope *s = scope;

  // First go up the chain checking for the name.
  while (s) {
    if (ht_contains_ptr(&s->scope, key)) {
      // If we find it, replace it.
      ht_insert_ptr(&s->scope, key, value);
      return;
    }
    s = s->up;
  }

  // If we never find it, insert it in the "lowest" scope.
  ht_insert_ptr(&scope->scope, key, value);
}

lisp_symbol *lisp_symbol_new(lisp_runtime *rt, char *sym)
{
  lisp_symbol *err = (lisp_symbol*)lisp_new(rt, type_symbol);
  int len = strlen(sym);
  err->sym = malloc(len + 1);
  strncpy(err->sym, sym, len);
  err->sym[len] = '\0';
  return err;
}

lisp_error *lisp_error_new(lisp_runtime *rt, char *message)
{
  lisp_error *err = (lisp_error*)lisp_new(rt, type_error);
  int len = strlen(message);
  err->message = malloc(len + 1);
  strncpy(err->message, message, len);
  err->message[len] = '\0';
  return err;
}

lisp_builtin *lisp_builtin_new(lisp_runtime *rt, char *name,
                               lisp_builtin_func call)
{
  lisp_builtin *builtin = (lisp_builtin*)lisp_new(rt, type_builtin);
  builtin->call = call;
  builtin->name = name;
  return builtin;
}

lisp_value *lisp_nil_new(lisp_runtime *rt)
{
  if (rt->nil == NULL) {
    rt->nil = lisp_new(rt, type_list);
  }
  return rt->nil;
}

lisp_value *lisp_eval_list(lisp_runtime *rt, lisp_scope *scope, lisp_value *l)
{
  if (lisp_nil_p(l)) {
    return l;
  }
  lisp_list *list = (lisp_list*) l;
  lisp_list *result = (lisp_list*)lisp_new(rt, type_list);
  result->left = lisp_eval(rt, scope, list->left);
  result->right = lisp_eval_list(rt, scope, list->right);
  return (lisp_value*) result;
}

int lisp_list_length(lisp_list *list)
{
  int length = 0;
  while (list->type == type_list && !lisp_nil_p((lisp_value*)list)) {
    length++;
    list = (lisp_list*)list->right;
  }
  return length;
}

lisp_value *lisp_quote(lisp_runtime *rt, lisp_value *value) {
  lisp_list *l = (lisp_list*)lisp_new(rt, type_list);
  lisp_symbol *q = lisp_symbol_new(rt, "quote");
  l->left = (lisp_value*)q;
  lisp_list *s = (lisp_list*) lisp_new(rt, type_list);
  s->right = lisp_nil_new(rt);
  l->right = (lisp_value*)s;
  s->left = value;
  return (lisp_value*)l;
}

static lisp_type *lisp_get_type(char c)
{
  switch (c) {
  case 'd':
    return type_integer;
  case 'l':
    return type_list;
  case 's':
    return type_symbol;
  case 'S':
    return type_string;
  case 'o':
    return type_scope;
  case 'e':
    return type_error;
  case 'b':
    return type_builtin;
  case 't':
    return type_type;
  }
  return NULL;
}

bool lisp_get_args(lisp_list *list, char *format, ...)
{
  va_list va;
  va_start(va, format);
  lisp_value **v;
  while (!lisp_nil_p((lisp_value*)list) && *format != '\0') {
    lisp_type *type = lisp_get_type(*format);
    if (type != NULL && type != list->left->type) {
      return false;
    }
    v = va_arg(va, lisp_value**);
    *v = list->left;
    list = (lisp_list*)list->right;
    format += 1;
  }
  if (strlen(format) != 0 || !lisp_nil_p((lisp_value*)list)) {
    return false;
  }
  return true;
}

static lisp_value *lisp_builtin_eval(lisp_runtime *rt, lisp_scope *scope,
                                     lisp_value *arguments)
{
  lisp_list *evald = (lisp_list*)lisp_eval_list(rt, scope, arguments);
  lisp_value *result = lisp_eval(rt, scope, evald->left);
  return result;
}

static lisp_value *lisp_builtin_car(lisp_runtime *rt, lisp_scope *scope,
                                    lisp_value *a)
{
  lisp_list *firstarg;
  lisp_list *arglist = (lisp_list*) lisp_eval_list(rt, scope, a);
  if (!lisp_get_args(arglist, "l", &firstarg)) {
    return (lisp_value*)lisp_error_new(rt, "wrong arguments to car");
  }
  if (lisp_list_length(firstarg) == 0) {
    return (lisp_value*)lisp_error_new(rt, "expected at least one item");
  }
  return firstarg->left;
}

static lisp_value *lisp_builtin_cdr(lisp_runtime *rt, lisp_scope *scope,
                                    lisp_value *a)
{
  lisp_list *firstarg;
  lisp_list *arglist = (lisp_list*) lisp_eval_list(rt, scope, a);
  if (!lisp_get_args(arglist, "l", &firstarg)) {
    return (lisp_value*) lisp_error_new(rt, "wrong arguments to cdr");
  }
  // save rv because firstarg may be deleted after decref
  return firstarg->right;
}

static lisp_value *lisp_builtin_quote(lisp_runtime *rt, lisp_scope *scope,
                                      lisp_value *a)
{
  (void)scope;
  lisp_value *firstarg;
  lisp_list *arglist = (lisp_list*) a;
  if (!lisp_get_args(arglist, "*", &firstarg)) {
    return (lisp_value*) lisp_error_new(rt, "wrong arguments to quote");
  }
  return arglist->left;
}

static lisp_value *lisp_builtin_cons(lisp_runtime *rt, lisp_scope *scope,
                                     lisp_value *a)
{
  lisp_value *a1;
  lisp_value *l;
  lisp_list *arglist = (lisp_list*) lisp_eval_list(rt, scope, a);
  if (!lisp_get_args(arglist, "**", &a1, &l)) {
    return (lisp_value*) lisp_error_new(rt, "wrong arguments to cons");
  }
  lisp_list *new = (lisp_list*)lisp_new(rt, type_list);
  new->left = a1;
  new->right = (lisp_value*)l;
  return (lisp_value*)new;
}

static lisp_value *lisp_builtin_lambda(lisp_runtime *rt, lisp_scope *scope,
                                       lisp_value *a)
{
  lisp_list *argnames;
  lisp_value *code;
  lisp_list *our_args = (lisp_list*)a;
  (void)scope;

  if (!lisp_get_args(our_args, "l*", &argnames, &code)) {
    return (lisp_value*) lisp_error_new(rt, "expected argument list and code");
  }

  lisp_list *it = argnames;
  while (!lisp_nil_p((lisp_value*)it)) {
    if (it->left->type != type_symbol) {
      return (lisp_value*) lisp_error_new(rt, "argument names must be symbols");
    }
    it = (lisp_list*) it->right;
  }

  lisp_lambda *lambda = (lisp_lambda*)lisp_new(rt, type_lambda);
  lambda->args = argnames;
  lambda->code = code;
  lambda->closure = scope;
  return (lisp_value*) lambda;
}

static lisp_value *lisp_builtin_define(lisp_runtime *rt, lisp_scope *scope,
                                       lisp_value *a)
{
  lisp_symbol *s;
  lisp_value *expr;

  if (!lisp_get_args((lisp_list*)a, "s*", &s, &expr)) {
    return (lisp_value*) lisp_error_new(rt, "expected name and expression");
  }

  lisp_value *evald = lisp_eval(rt, scope, expr);
  lisp_scope_replace_or_insert(scope, s, evald);
  //lisp_scope_bind(scope, s, evald);
  return evald;
}

static lisp_value *lisp_builtin_plus(lisp_runtime *rt, lisp_scope *scope,
                                     lisp_value *a)
{
  lisp_integer *i;
  lisp_list *args = (lisp_list*)lisp_eval_list(rt, scope, a);
  int sum = 0;

  while (!lisp_nil_p((lisp_value*)args)) {
    if (args->left->type != type_integer) {
      return (lisp_value*) lisp_error_new(rt, "expect integers for addition");
    }
    i = (lisp_integer*) args->left;
    sum += i->x;
    args = (lisp_list*)args->right;
  }

  i = (lisp_integer*)lisp_new(rt, type_integer);
  i->x = sum;
  return (lisp_value*)i;
}

static lisp_value *lisp_builtin_minus(lisp_runtime *rt, lisp_scope *scope,
                                      lisp_value *a)
{
  lisp_integer *i;
  lisp_list *args = (lisp_list*)lisp_eval_list(rt, scope, a);
  int val = 0;
  int len = lisp_list_length(args);

  if (len < 1) {
    return (lisp_value*) lisp_error_new(rt, "expected at least one arg");
  } else if (len == 1) {
    i = (lisp_integer*) args->left;
    val = - i->x;
  } else {
    i = (lisp_integer*) args->left;
    val = i->x;
    args = (lisp_list*)args->right;
    while (!lisp_nil_p((lisp_value*)args)) {
      if (args->left->type != type_integer) {
        return (lisp_value*)lisp_error_new(rt, "expected integer");
      }
      i = (lisp_integer*) args->left;
      val -= i->x;
      args = (lisp_list*) args->right;
    }
  }

  i = (lisp_integer*)lisp_new(rt, type_integer);
  i->x = val;
  return (lisp_value*)i;
}

static lisp_value *lisp_builtin_multiply(lisp_runtime *rt, lisp_scope *scope,
                                         lisp_value *a)
{
  lisp_integer *i;
  lisp_list *args = (lisp_list*) lisp_eval_list(rt, scope, a);
  int product = 1;

  while (!lisp_nil_p((lisp_value*)args)) {
    if (args->left->type != type_integer) {
      return (lisp_value*) lisp_error_new(rt, "expect integers for multiplication");
    }
    i = (lisp_integer*) args->left;
    product *= i->x;
    args = (lisp_list*)args->right;
  }

  i = (lisp_integer*)lisp_new(rt, type_integer);
  i->x = product;
  return (lisp_value*)i;
}

static lisp_value *lisp_builtin_divide(lisp_runtime *rt, lisp_scope *scope,
                                       lisp_value *a)
{
  lisp_integer *i;
  lisp_list *args = (lisp_list*)lisp_eval_list(rt, scope, a);
  int val = 0;
  int len = lisp_list_length(args);

  if (len < 1) {
    return (lisp_value*) lisp_error_new(rt, "expected at least one arg");
  }
  i = (lisp_integer*) args->left;
  val = i->x;
  args = (lisp_list*)args->right;
  while (!lisp_nil_p((lisp_value*)args)) {
    if (args->left->type != type_integer) {
      return (lisp_value*)lisp_error_new(rt, "expected integer");
    }
    i = (lisp_integer*) args->left;
    if (i->x == 0) {
      return (lisp_value*) lisp_error_new(rt, "divide by zero");
    }
    val /= i->x;
    args = (lisp_list*) args->right;
  }

  i = (lisp_integer*)lisp_new(rt, type_integer);
  i->x = val;
  return (lisp_value*)i;
}

static lisp_value *lisp_builtin_cmp_util(lisp_runtime *rt, lisp_scope *scope,
                                         lisp_value *a)
{
  lisp_integer *first, *second;
  lisp_list *args = (lisp_list*) lisp_eval_list(rt, scope, a);

  if (!lisp_get_args((lisp_list*)args, "dd", &first, &second)) {
    return (lisp_value*) lisp_error_new(rt, "expected two integers");
  }

  lisp_integer *result = (lisp_integer*)lisp_new(rt, type_integer);
  result->x = first->x - second->x;
  return (lisp_value*)result;
}

static lisp_value *lisp_builtin_eq(lisp_runtime *rt, lisp_scope *scope,
                                   lisp_value *a)
{
  lisp_integer *v = (lisp_integer*)lisp_builtin_cmp_util(rt, scope, a);
  if (v->type == type_integer) {
    v->x = (v->x == 0);
  }
  return (lisp_value*)v;
}

static lisp_value *lisp_builtin_gt(lisp_runtime *rt, lisp_scope *scope,
                                   lisp_value *a)
{
  lisp_integer *v = (lisp_integer*)lisp_builtin_cmp_util(rt, scope, a);
  if (v->type == type_integer) {
    v->x = (v->x > 0);
  }
  return (lisp_value*)v;
}

static lisp_value *lisp_builtin_ge(lisp_runtime *rt, lisp_scope *scope,
                                   lisp_value *a)
{
  lisp_integer *v = (lisp_integer*)lisp_builtin_cmp_util(rt, scope, a);
  if (v->type == type_integer) {
    v->x = (v->x >= 0);
  }
  return (lisp_value*)v;
}

static lisp_value *lisp_builtin_lt(lisp_runtime *rt, lisp_scope *scope,
                                   lisp_value *a)
{
  lisp_integer *v = (lisp_integer*)lisp_builtin_cmp_util(rt, scope, a);
  if (v->type == type_integer) {
    v->x = (v->x < 0);
  }
  return (lisp_value*)v;
}

static lisp_value *lisp_builtin_le(lisp_runtime *rt, lisp_scope *scope,
                                   lisp_value *a)
{
  lisp_integer *v = (lisp_integer*)lisp_builtin_cmp_util(rt, scope, a);
  if (v->type == type_integer) {
    v->x = (v->x <= 0);
  }
  return (lisp_value*)v;
}

static lisp_value *lisp_builtin_if(lisp_runtime *rt, lisp_scope *scope,
                                   lisp_value *a)
{
  lisp_value *condition, *body_true, *body_false;

  if (!lisp_get_args((lisp_list*)a, "***", &condition, &body_true, &body_false)) {
    return (lisp_value*) lisp_error_new(rt, "expected condition and two bodies");
  }

  condition = lisp_eval(rt, scope, condition);
  if (condition->type == type_integer && ((lisp_integer*)condition)->x) {
    return lisp_eval(rt, scope, body_true);
  } else {
    return lisp_eval(rt, scope, body_false);
  }
}

static lisp_value *lisp_builtin_null_p(lisp_runtime *rt, lisp_scope *scope,
                                       lisp_value *a)
{
  lisp_value *v;
  lisp_list *args = (lisp_list*) lisp_eval_list(rt, scope, a);

  if (!lisp_get_args(args, "*", &v)) {
    return (lisp_value*) lisp_error_new(rt, "expected one argument");
  }

  lisp_integer *result = (lisp_integer*) lisp_new(rt, type_integer);
  result->x = (int) lisp_nil_p(v);
  return (lisp_value*)result;
}

static lisp_list *get_quoted_left_items(lisp_runtime *rt, lisp_list *list_of_lists)
{
  lisp_list *left_items = NULL, *rv;
  while (!lisp_nil_p((lisp_value*)list_of_lists)) {
    // Create or advance left_items to the next list.
    if (left_items == NULL) {
      left_items = (lisp_list*) lisp_new(rt, type_list);
      rv = left_items;
    } else {
      left_items->right = lisp_new(rt, type_list);
      left_items = (lisp_list*) left_items->right;
    }
    // Check the next node in the list to make sure it's actually a list.
    if (lisp_nil_p(list_of_lists->left)) {
      return NULL;
    }
    // Get the next node in the list and get the argument.
    lisp_list *l = (lisp_list*) list_of_lists->left;
    left_items->left = lisp_quote(rt, l->left);
    list_of_lists = (lisp_list*) list_of_lists->right;
  }
  left_items->right = lisp_nil_new(rt);
  return rv;
}

static lisp_list *advance_lists(lisp_runtime *rt, lisp_list *list_of_lists)
{
  lisp_list *right_items = NULL, *rv;
  while (!lisp_nil_p((lisp_value*)list_of_lists)) {
    // Create or advance left_items to the next list.
    if (right_items == NULL) {
      right_items = (lisp_list*) lisp_new(rt, type_list);
      rv = right_items;
    } else {
      right_items->right = lisp_new(rt, type_list);
      right_items = (lisp_list*) right_items->right;
    }
    // Check the next node in the list to make sure it's actually a list.
    if (list_of_lists->left->type != type_list) {
      return NULL;
    }
    // Get the next node in the list and get the argument.
    lisp_list *l = (lisp_list*) list_of_lists->left;
    right_items->left = l->right;
    list_of_lists = (lisp_list*) list_of_lists->right;
  }
  right_items->right = lisp_nil_new(rt);
  return rv;
}

static lisp_value *lisp_builtin_map(lisp_runtime *rt, lisp_scope *scope,
                                    lisp_value *a)
{
  lisp_value *f;
  lisp_list *ret = NULL, *args, *rv;
  lisp_list *map_args = (lisp_list *) lisp_eval_list(rt, scope, a);

  // Get the function from the first argument in the list.
  f = map_args->left;
  if (map_args->right->type != type_list) {
    return (lisp_value*) lisp_error_new(rt, "need at least two arguments");
  }
  map_args = (lisp_list*) map_args->right;
  while ((args = get_quoted_left_items(rt, map_args)) != NULL) {
    if (ret == NULL) {
      ret = (lisp_list*) lisp_new(rt, type_list);
      rv = ret;
    } else {
      ret->right = lisp_new(rt, type_list);
      ret = (lisp_list*) ret->right;
    }
    ret->left = lisp_call(rt, scope, f, (lisp_value*)args);
    map_args = advance_lists(rt, map_args);
  }
  ret->right = lisp_nil_new(rt);
  return (lisp_value*) rv;
}

static lisp_value *lisp_builtin_reduce(lisp_runtime *rt, lisp_scope *scope, lisp_value *a)
{
  lisp_list *args = (lisp_list*) lisp_eval_list(rt, scope, a);
  int length = lisp_list_length(args);
  lisp_value *callable, *initializer;
  lisp_list *list;

  if (length == 2) {
    if (!lisp_get_args(args, "*l", &callable, &list)) {
      return (lisp_value*) lisp_error_new(rt, "reduce: callable and list required");
    }
    if (lisp_list_length(list) < 2) {
      return (lisp_value*) lisp_error_new(rt, "reduce: list must have at least 2 entries");
    }
    initializer = list->left;
    list = (lisp_list*)list->right;
 } else if (length == 3) {
    if (!lisp_get_args(args, "**l", &callable, &initializer, &list)) {
      return (lisp_value*) lisp_error_new(rt, "reduce: callable, initializer, and list required");
    }
    if (lisp_list_length(list) < 1) {
      return (lisp_value*) lisp_error_new(rt, "reduce: list must have at least 1 entry");
    }
  } else {
    return (lisp_value*) lisp_error_new(rt, "reduce: 2 or 3 arguments required");
  }

  while (!lisp_nil_p((lisp_value*)list)) {
    initializer = lisp_call(rt, scope, callable,
                            (lisp_value*) lisp_new_pair_list(rt, initializer, list->left));
    list = (lisp_list*) list->right;
  }
  return initializer;
}

void lisp_scope_populate_builtins(lisp_runtime *rt, lisp_scope *scope)
{
  lisp_scope_add_builtin(rt, scope, "eval", lisp_builtin_eval);
  lisp_scope_add_builtin(rt, scope, "car", lisp_builtin_car);
  lisp_scope_add_builtin(rt, scope, "cdr", lisp_builtin_cdr);
  lisp_scope_add_builtin(rt, scope, "quote", lisp_builtin_quote);
  lisp_scope_add_builtin(rt, scope, "cons", lisp_builtin_cons);
  lisp_scope_add_builtin(rt, scope, "lambda", lisp_builtin_lambda);
  lisp_scope_add_builtin(rt, scope, "define", lisp_builtin_define);
  lisp_scope_add_builtin(rt, scope, "+", lisp_builtin_plus);
  lisp_scope_add_builtin(rt, scope, "-", lisp_builtin_minus);
  lisp_scope_add_builtin(rt, scope, "*", lisp_builtin_multiply);
  lisp_scope_add_builtin(rt, scope, "/", lisp_builtin_divide);
  lisp_scope_add_builtin(rt, scope, "==", lisp_builtin_eq);
  lisp_scope_add_builtin(rt, scope, "=", lisp_builtin_eq);
  lisp_scope_add_builtin(rt, scope, ">", lisp_builtin_gt);
  lisp_scope_add_builtin(rt, scope, ">=", lisp_builtin_ge);
  lisp_scope_add_builtin(rt, scope, "<", lisp_builtin_lt);
  lisp_scope_add_builtin(rt, scope, "<=", lisp_builtin_le);
  lisp_scope_add_builtin(rt, scope, "if", lisp_builtin_if);
  lisp_scope_add_builtin(rt, scope, "null?", lisp_builtin_null_p);
  lisp_scope_add_builtin(rt, scope, "map", lisp_builtin_map);
  lisp_scope_add_builtin(rt, scope, "reduce", lisp_builtin_reduce);
}