/* Copyright 2009
 * Kaz Kylheku <kkylheku@gmail.com>
 * Vancouver, Canada
 * All rights reserved.
 *
 * BSD License:
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 *
 *   1. Redistributions of source code must retain the above copyright
 *      notice, this list of conditions and the following disclaimer.
 *   2. Redistributions in binary form must reproduce the above copyright
 *      notice, this list of conditions and the following disclaimer in
 *      the documentation and/or other materials provided with the
 *      distribution.
 *   3. The name of the author may not be used to endorse or promote
 *      products derived from this software without specific prior
 *      written permission.
 *
 * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
 * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 */

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <assert.h>
#include <limits.h>
#include <stdarg.h>
#include <dirent.h>
#include "lib.h"
#include "gc.h"

#define max(a, b) ((a) > (b) ? (a) : (b))
#define min(a, b) ((a) < (b) ? (a) : (b))

obj_t *interned_syms;

obj_t *null, *t, *cons_t, *str_t, *chr_t, *num_t, *sym_t, *fun_t, *vec_t;
obj_t *stream_t, *lcons_t, *var, *regex, *set, *cset, *wild, *oneplus;
obj_t *zeroplus, *optional, *compound, *or;
obj_t *skip, *trailer, *block, *next, *fail, *accept;
obj_t *all, *some, *none, *maybe, *collect, *until, *coll;
obj_t *output, *single, *frst, *lst, *empty, *repeat, *rep;
obj_t *flattn, *forget, *mrge, *bind, *cat, *dir;

obj_t *zero, *one, *two, *negone, *maxint, *minint;
obj_t *null_string;
obj_t *nil_string;
obj_t *null_list;

obj_t *identity_f;
obj_t *equal_f;

const char *progname;
void *(*oom_realloc)(void *, size_t);


obj_t *identity(obj_t *obj)
{
  return obj;
}

static obj_t *identity_tramp(obj_t *env, obj_t *obj)
{
  (void) env;
  return identity(obj);
}

static obj_t *equal_tramp(obj_t *env, obj_t *, obj_t *);

obj_t *typeof(obj_t *obj)
{
  if (obj == nil)
    return null;
  switch (obj->t.type) {
  case CONS: return cons_t;
  case STR: return str_t;
  case CHR: return chr_t;
  case NUM: return num_t;
  case SYM: return sym_t;
  case FUN: return fun_t;
  case VEC: return vec_t;
  case STREAM: return stream_t;
  case LCONS: return lcons_t;
  case COBJ: return obj->co.cls;
  }
  assert (0 && "corrupt type field");
}

obj_t *car(obj_t *cons)
{
  if (cons == nil)
    return nil;
  else switch (cons->t.type) {
  case CONS:
    return cons->c.car;
  case LCONS:
    if (cons->lc.func == nil) {
      return cons->lc.car;
    } else {
      if (!funcall1(cons->lc.func, cons))
        return nil;
      return cons->lc.car;
    }
  default:
    assert (0 && "corrupt type field");
  }
}

obj_t *cdr(obj_t *cons)
{
  if (cons == nil)
    return nil;
  else switch (cons->t.type) {
  case CONS:
    return cons->c.cdr;
  case LCONS:
    if (cons->lc.func == nil) {
      return cons->lc.cdr;
    } else {
      if (!funcall1(cons->lc.func, cons))
        return nil;
      return cons->lc.cdr;
    }
  default:
    assert (0 && "corrupt type field");
  }
}

obj_t **car_l(obj_t *cons)
{
  switch (cons->t.type) {
  case CONS:
    return &cons->c.car;
  case LCONS:
    funcall1(cons->lc.func, cons);
    return &cons->lc.car;
  default:
    assert (0 && "corrupt type field");
  }
}

obj_t **cdr_l(obj_t *cons)
{
  switch (cons->t.type) {
  case CONS:
    return &cons->c.cdr;
  case LCONS:
    funcall1(cons->lc.func, cons);
    return &cons->lc.cdr;
  default:
    assert (0 && "corrupt type field");
  }
}

obj_t *first(obj_t *cons)
{
  return car(cons);
}

obj_t *rest(obj_t *cons)
{
  return cdr(cons);
}

obj_t *second(obj_t *cons)
{
  return car(cdr(cons));
}

obj_t *third(obj_t *cons)
{
  return car(cdr(cdr(cons)));
}

obj_t *fourth(obj_t *cons)
{
  return car(cdr(cdr(cdr(cons))));
}

obj_t *fifth(obj_t *cons)
{
  return car(cdr(cdr(cdr(cdr(cons)))));
}

obj_t *sixth(obj_t *cons)
{
  return car(cdr(cdr(cdr(cdr(cdr(cons))))));
}

obj_t **tail(obj_t *cons)
{
  while (cdr(cons))
    cons = cdr(cons);
  return cdr_l(cons);
}

obj_t *copy_list(obj_t *list)
{
  list_collect_decl (out, tail);

  while (consp(list)) {
    list_collect(tail, car(list));
    list = cdr(list);
  }

  list_collect_terminate(tail, list);

  return out;
}

obj_t *nreverse(obj_t *in)
{
  obj_t *rev = nil;

  while (in) {
    obj_t *temp = cdr(in);
    *cdr_l(in) = rev;
    rev = in;
    in = temp;
  }

  return rev;
}

obj_t *reverse(obj_t *in)
{
  obj_t *rev = nil;

  while (in) {
    rev = cons(car(in), rev);
    in = cdr(in);
  }

  return rev;
}

obj_t *append2(obj_t *list1, obj_t *list2)
{
  list_collect_decl (out, tail);

  while (list1) {
    list_collect(tail, car(list1));
    list1 = cdr(list1);
  }

  list_collect_terminate(tail, list2);
  return out;
}

obj_t *nappend2(obj_t *list1, obj_t *list2)
{
  obj_t *temp, *iter;

  if (list1 == nil)
    return list2;

  for (iter = list1; (temp = cdr(iter)) != nil; iter = temp)
    ; /* empty */

  *cdr_l(iter) = list2;
  return list1;
}

obj_t *flatten_helper(obj_t *env, obj_t *item)
{
  return flatten(item);
}

obj_t *memq(obj_t *obj, obj_t *list)
{
  while (list && car(list) != obj)
    list = cdr(list);
  return list;
}

obj_t *tree_find(obj_t *obj, obj_t *tree)
{
  if (equal(obj, tree))
    return t;
  else if (consp(tree))
    return some_satisfy(tree, bind2(func_n2(tree_find), obj), nil);
  return nil;
}

obj_t *some_satisfy(obj_t *list, obj_t *pred, obj_t *key)
{
  if (!key)
    key = identity_f;

  for (; list; list = cdr(list)) {
    if (funcall1(pred, funcall1(key, car(list))))
      return t;
  }

  return nil;
}

obj_t *all_satisfy(obj_t *list, obj_t *pred, obj_t *key)
{
  if (!key)
    key = identity_f;

  for (; list; list = cdr(list)) {
    if (!funcall1(pred, funcall1(key, car(list))))
      return nil;
  }

  return t;
}

obj_t *none_satisfy(obj_t *list, obj_t *pred, obj_t *key)
{
  if (!key)
    key = identity_f;

  for (; list; list = cdr(list)) {
    if (funcall1(pred, funcall1(key, car(list))))
      return nil;
  }

  return t;
}

obj_t *flatten(obj_t *list)
{
  if (atom(list))
    return cons(list, nil);

  return mappend(func_f1(nil, flatten_helper), list);
}

long c_num(obj_t *num);

obj_t *equal(obj_t *left, obj_t *right)
{
  if (left == nil && right == nil)
    return t;

  if (left == nil || right == nil)
    return nil;

  switch (left->t.type) {
  case CONS:
  case LCONS:
    if ((right->t.type == CONS || left->t.type == LCONS) &&
        equal(car(left), car(right)) &&
        equal(cdr(left), cdr(right)))
    {
      return t;
    }
    return nil;
  case STR:
    if (right->t.type == STR &&
        strcmp(left->st.str, right->st.str) == 0)
      return t;
    return nil;
  case CHR:
    if (right->t.type == CHR &&
        left->ch.ch == right->ch.ch)
      return t;
    return nil;
  case NUM:
    if (right->t.type == NUM &&
        left->n.val == right->n.val)
      return t;
    return nil;
  case SYM:
    return right == left ? t : nil;
  case FUN:
    if (right->t.type == FUN &&
        left->f.functype == right->f.functype)
    {
      switch (left->f.functype) {
      case FINTERP: return (equal(left->f.f.interp_fun, right->f.f.interp_fun));
      case F0: return (left->f.f.f0 == right->f.f.f0) ? t : nil;
      case F1: return (left->f.f.f1 == right->f.f.f1) ? t : nil;
      case F2: return (left->f.f.f2 == right->f.f.f2) ? t : nil;
      case F3: return (left->f.f.f3 == right->f.f.f3) ? t : nil;
      case F4: return (left->f.f.f4 == right->f.f.f4) ? t : nil;
      case N0: return (left->f.f.n0 == right->f.f.n0) ? t : nil;
      case N1: return (left->f.f.n1 == right->f.f.n1) ? t : nil;
      case N2: return (left->f.f.n2 == right->f.f.n2) ? t : nil;
      case N3: return (left->f.f.n3 == right->f.f.n3) ? t : nil;
      case N4: return (left->f.f.n4 == right->f.f.n4) ? t : nil;
      }
      return nil;
    }
    return nil;
  case VEC:
    if (right->t.type == VEC) {
      long i, fill;
      if (!equal(left->v.vec[vec_fill], right->v.vec[vec_fill]))
        return nil;
      fill = c_num(left->v.vec[vec_fill]);
      for (i = 0; i < fill; i++) {
        if (!equal(left->v.vec[i], right->v.vec[i]))
          return nil;
      }
      return t;
    }
    return nil;
  case STREAM:
    return nil; /* Different stream objects never equal. */
  case COBJ:
    if (right->t.type == COBJ)
      return left->co.ops->equal(left, right);
    return nil;
  }

  assert (0 && "notreached");
  return nil;
}

static obj_t *equal_tramp(obj_t *env, obj_t *left, obj_t *right)
{
  (void) env;
  return equal(left, right);
}

void *chk_malloc(size_t size)
{
  void *ptr = malloc(size);
  if (size && ptr == 0)
    ptr = oom_realloc(0, size);
  return ptr;
}

void *chk_realloc(void *old, size_t size)
{
  void *newptr = realloc(old, size);
  if (size != 0 && newptr == 0)
    newptr = oom_realloc(old, size);
  return newptr;
}

void *chk_strdup(const char *str)
{
  size_t size = strlen(str) + 1;
  char *copy = chk_malloc(size);
  memcpy(copy, str, size);
  return copy;
}


obj_t *cons(obj_t *car, obj_t *cdr)
{
  obj_t *obj = make_obj();
  obj->c.type = CONS;
  obj->c.car = car;
  obj->c.cdr = cdr;
  return obj;
}

obj_t *list(obj_t *first, ...)
{
  va_list vl;
  obj_t *list = nil;
  obj_t *array[32], **ptr = array;

  if (first != nao) {
    obj_t *next = first;

    va_start (vl, first);

    do {
      *ptr++ = next;
      if (ptr == array + 32)
        abort();
      next = va_arg(vl, obj_t *);
    } while (next != nao);

    while (ptr > array)
      list = cons(*--ptr, list);
  }

  return list;
}

obj_t *consp(obj_t *obj)
{
  if (!obj)
    return nil;
  return (obj->t.type == CONS || obj->t.type == LCONS) ? t : nil;
}

obj_t *nullp(obj_t *obj)
{
  return obj == 0 ? t : nil;
}

obj_t *atom(obj_t *obj)
{
  return (obj == nil || (obj->t.type != CONS && obj->t.type != LCONS))
         ? t : nil;
}

obj_t *listp(obj_t *obj)
{
  return (obj == nil || obj->t.type == CONS || obj->t.type == LCONS)
         ? t : nil;
}

obj_t *length(obj_t *list)
{
  long len = 0;
  while (consp(list)) {
    len++;
    list = cdr(list);
  }
  return num(len);
}

obj_t *num(long val)
{
  obj_t *obj = make_obj();
  obj->n.type = NUM;
  obj->n.val = val;
  return obj;
}

long c_num(obj_t *num)
{
  assert (num && num->t.type == NUM);
  return num->n.val;
}

obj_t *nump(obj_t *num)
{
  return (num && num->n.type == NUM) ? t : nil;
}

obj_t *plus(obj_t *anum, obj_t *bnum)
{
  long a = c_num(anum);
  long b = c_num(bnum);

  assert (a <= 0 || b <= 0 || LONG_MAX - b >= a);
  assert (a >= 0 || b >= 0 || LONG_MIN - b >= a);

  return num(a + b);
}

obj_t *minus(obj_t *anum, obj_t *bnum)
{
  long a = c_num(anum);
  long b = c_num(bnum);

  assert (b != LONG_MIN || LONG_MIN == -LONG_MAX);
  assert (a <= 0 || -b <= 0 || LONG_MAX + b >= a);
  assert (a >= 0 || -b >= 0 || LONG_MIN + b >= a);

  return num(a - b);
}

obj_t *neg(obj_t *anum)
{
  long n = c_num(anum);
  return num(-n);
}

obj_t *zerop(obj_t *num)
{
  return c_num(num) == 0 ? t : nil;
}

obj_t *gt(obj_t *anum, obj_t *bnum)
{
  return c_num(anum) > c_num(bnum) ? t : nil;
}

obj_t *lt(obj_t *anum, obj_t *bnum)
{
  return c_num(anum) < c_num(bnum) ? t : nil;
}

obj_t *ge(obj_t *anum, obj_t *bnum)
{
  return c_num(anum) >= c_num(bnum) ? t : nil;
}

obj_t *le(obj_t *anum, obj_t *bnum)
{
  return c_num(anum) <= c_num(bnum) ? t : nil;
}

obj_t *numeq(obj_t *anum, obj_t *bnum)
{
  return c_num(anum) == c_num(bnum) ? t : nil;
}

obj_t *max2(obj_t *anum, obj_t *bnum)
{
  return c_num(anum) > c_num(bnum) ? anum : bnum;
}

obj_t *min2(obj_t *anum, obj_t *bnum)
{
  return c_num(anum) < c_num(bnum) ? anum : bnum;
}

obj_t *string(char *str)
{
  obj_t *obj = make_obj();
  obj->st.type = STR;
  obj->st.str = str;
  obj->st.len = nil;
  return obj;
}

obj_t *mkstring(obj_t *len, obj_t *ch)
{
  char *str = chk_malloc(c_num(len) + 1);
  memset(str, c_chr(ch), c_num(len));
  str[c_num(len)] = 0;
  return string(str);
}

obj_t *copy_str(obj_t *str)
{
  return string(strdup(c_str(str)));
}

obj_t *stringp(obj_t *str)
{
  return (str && str->st.type == STR) ? t : nil;
}

obj_t *length_str(obj_t *str)
{
  assert (str && str->t.type == STR);
  if (!str->st.len)
    str->st.len = num(strlen(str->st.str));
  return str->st.len;
}

const char *c_str(obj_t *str)
{
  assert (str && str->t.type == STR);
  return str->st.str;
}

obj_t *search_str(obj_t *haystack, obj_t *needle, obj_t *start_num,
                  obj_t *from_end)
{
  const char *h = c_str(haystack);
  long len = c_num(length_str(haystack));
  long start = c_num(start_num);

  if (start > len) {
    return nil;
  } else {
    const char *n = c_str(needle), *good = 0, *pos, *from = h + start;

    do {
      pos = strstr(from, n);
    } while (pos && (good = pos) && from_end && *(from = pos + 1));
    return (good == 0) ? nil : num(good - h);
  }
}

obj_t *search_str_tree(obj_t *haystack, obj_t *tree, obj_t *start_num,
                       obj_t *from_end)
{
  if (stringp(tree)) {
    obj_t *result = search_str(haystack, tree, start_num, from_end);
    if (result)
      return cons(result, length_str(tree));
  } else if (consp(tree)) {
    while (tree) {
      obj_t *result = search_str_tree(haystack, car(tree), start_num, from_end);
      if (result)
        return result;
      tree = cdr(tree);
    }
  }

  return nil;
}

obj_t *sub_str(obj_t *str_in, obj_t *from_num, obj_t *to_num)
{
  const char *str = c_str(str_in);
  size_t len = c_num(length_str(str_in));
  long from = c_num(from_num);
  long to = to_num ? c_num(to_num) : len;

  if (to < 0)
    to = 0;
  if (from < 0)
    from = 0;
  if (from > len)
    from = len;
  if (to > len)
    to = len;

  if (from >= to) {
    return null_string;
  } else {
    size_t size = to - from + 1;
    char *sub = chk_malloc(size);
    strncpy(sub, str + from, size);
    sub[size-1] = 0;
    return string(sub);
  }
}

obj_t *cat_str(obj_t *list, obj_t *sep)
{
  long total = 0;
  obj_t *iter;
  char *str, *ptr;
  long len_sep = sep ? c_num(length_str(sep)) : 0;

  for (iter = list; iter != nil; iter = cdr(iter)) {
    obj_t *item = car(iter);
    if (!item)
      continue;
    if (!stringp(item))
      return nil;
    total += c_num(length_str(item));
    if (len_sep && cdr(iter))
      total += len_sep;
  }

  str = chk_malloc(total + 1);

  for (ptr = str, iter = list; iter != nil; iter = cdr(iter)) {
    obj_t *item = car(iter);
    long len;
    if (!item)
      continue;
    len = c_num(length_str(item));
    memcpy(ptr, c_str(item), len);
    ptr += len;
    if (len_sep && cdr(iter)) {
      memcpy(ptr, c_str(sep), len_sep);
      ptr += len_sep;
    }
  }
  *ptr = 0;

  return string(str);
}

obj_t *trim_str(obj_t *str)
{
  const char *start = c_str(str);
  const char *end = start + c_num(length_str(str));

  while (start[0] && isspace(start[0]))
    start++;

  while (end > start && isspace(end[-1]))
    end--;

  if (end == start) {
    return null_string;
  } else {
    size_t len = end - start;
    char *new = chk_malloc(len + 1);
    memcpy(new, start, len);
    new[len] = 0;
    return string(new);
  }
}

obj_t *string_lt(obj_t *astr, obj_t *bstr)
{
  int cmp = strcmp(c_str(astr), c_str(bstr));
  return cmp == -1 ? t : nil;
}

obj_t *chr(int ch)
{
  obj_t *obj = make_obj();
  obj->ch.type = CHR;
  obj->ch.ch = ch;
  return obj;
}

int c_chr(obj_t *chr)
{
  assert (chr && chr->t.type == CHR);
  return chr->ch.ch;
}

obj_t *sym_name(obj_t *sym)
{
  assert (sym && sym->t.type == SYM);
  return sym->s.name;
}

obj_t *make_sym(obj_t *name)
{
  obj_t *obj = make_obj();
  obj->s.type = SYM;
  obj->s.name = name;
  obj->s.val = nil;
  return obj;
}

obj_t *intern(obj_t *str)
{
  obj_t *iter;

  for (iter = interned_syms; iter != nil; iter = cdr(iter)) {
    obj_t *sym = car(iter);
    if (equal(sym_name(sym), str))
      return sym;
  }

  interned_syms = cons(make_sym(str), interned_syms);
  return car(interned_syms);
}

obj_t *symbolp(obj_t *sym)
{
  return (sym == nil || sym->s.type == SYM) ? t : nil;
}

obj_t *symbol_name(obj_t *sym)
{
  assert (sym == nil || sym->t.type == SYM);
  return sym ? sym->s.name : nil_string;
}

obj_t *func_f0(obj_t *env, obj_t *(*fun)(obj_t *))
{
  obj_t *obj = make_obj();
  obj->f.type = FUN;
  obj->f.functype = F0;
  obj->f.env = env;
  obj->f.f.f0 = fun;
  return obj;
}

obj_t *func_f1(obj_t *env, obj_t *(*fun)(obj_t *, obj_t *))
{
  obj_t *obj = make_obj();
  obj->f.type = FUN;
  obj->f.functype = F1;
  obj->f.env = env;
  obj->f.f.f1 = fun;
  return obj;
}

obj_t *func_f2(obj_t *env, obj_t *(*fun)(obj_t *, obj_t *, obj_t *))
{
  obj_t *obj = make_obj();
  obj->f.type = FUN;
  obj->f.functype = F2;
  obj->f.env = env;
  obj->f.f.f2 = fun;
  return obj;
}

obj_t *func_f3(obj_t *env, obj_t *(*fun)(obj_t *, obj_t *, obj_t *, obj_t *))
{
  obj_t *obj = make_obj();
  obj->f.type = FUN;
  obj->f.functype = F3;
  obj->f.env = env;
  obj->f.f.f3 = fun;
  return obj;
}

obj_t *func_f4(obj_t *env, obj_t *(*fun)(obj_t *, obj_t *, obj_t *, obj_t *,
                                         obj_t *))
{
  obj_t *obj = make_obj();
  obj->f.type = FUN;
  obj->f.functype = F4;
  obj->f.env = env;
  obj->f.f.f4 = fun;
  return obj;
}

obj_t *func_n0(obj_t *(*fun)(void))
{
  obj_t *obj = make_obj();
  obj->f.type = FUN;
  obj->f.functype = N0;
  obj->f.env = nil;
  obj->f.f.n0 = fun;
  return obj;
}

obj_t *func_n1(obj_t *(*fun)(obj_t *))
{
  obj_t *obj = make_obj();
  obj->f.type = FUN;
  obj->f.functype = N1;
  obj->f.env = nil;
  obj->f.f.n1 = fun;
  return obj;
}

obj_t *func_n2(obj_t *(*fun)(obj_t *, obj_t *))
{
  obj_t *obj = make_obj();
  obj->f.type = FUN;
  obj->f.functype = N2;
  obj->f.env = nil;
  obj->f.f.n2 = fun;
  return obj;
}

obj_t *func_n3(obj_t *(*fun)(obj_t *, obj_t *, obj_t *))
{
  obj_t *obj = make_obj();
  obj->f.type = FUN;
  obj->f.functype = N3;
  obj->f.f.n3 = fun;
  return obj;
}

obj_t *func_n4(obj_t *(*fun)(obj_t *, obj_t *, obj_t *, obj_t *))
{
  obj_t *obj = make_obj();
  obj->f.type = FUN;
  obj->f.functype = N4;
  obj->f.f.n4 = fun;
  return obj;
}


obj_t *apply(obj_t *fun, obj_t *arglist)
{
  obj_t *arg[4], **p = arg;

  assert (fun && fun->f.type == FUN);
  assert (arglist == nil || consp(arglist));

  *p++ = car(arglist); arglist = cdr(arglist);
  *p++ = car(arglist); arglist = cdr(arglist);
  *p++ = car(arglist); arglist = cdr(arglist);
  *p++ = car(arglist); arglist = cdr(arglist);

  switch (fun->f.functype) {
  case F0:
    return fun->f.f.f0(fun);
  case F1:
    return fun->f.f.f1(fun, arg[0]);
  case F2:
    return fun->f.f.f2(fun, arg[0], arg[1]);
  case F3:
    return fun->f.f.f3(fun, arg[0], arg[1], arg[2]);
  case F4:
    return fun->f.f.f4(fun, arg[0], arg[1], arg[2], arg[3]);
  case N0:
    return fun->f.f.n0();
  case N1:
    return fun->f.f.n1(arg[0]);
  case N2:
    return fun->f.f.n2(arg[0], arg[1]);
  case N3:
    return fun->f.f.n3(arg[0], arg[1], arg[2]);
  case N4:
    return fun->f.f.n4(arg[0], arg[1], arg[2], arg[3]);
  case FINTERP:
    abort();
  }

  assert (0 && "bad functype");
}

obj_t *funcall(obj_t *fun)
{
  assert (fun && fun->f.type == FUN);

  switch (fun->f.functype) {
  case F0:
    return fun->f.f.f0(fun->f.env);
  case N0:
    return fun->f.f.n0();
  default:
    abort();
  }
}

obj_t *funcall1(obj_t *fun, obj_t *arg)
{
  assert (fun && fun->f.type == FUN);

  switch (fun->f.functype) {
  case F1:
    return fun->f.f.f1(fun->f.env, arg);
  case N1:
    return fun->f.f.n1(arg);
  default:
    abort();
  }
}

obj_t *funcall2(obj_t *fun, obj_t *arg1, obj_t *arg2)
{
  assert (fun && fun->f.type == FUN);

  switch (fun->f.functype) {
  case F2:
    return fun->f.f.f2(fun->f.env, arg1, arg2);
  case N2:
    return fun->f.f.n2(arg1, arg2);
  default:
    abort();
  }
}

obj_t *reduce_left(obj_t *fun, obj_t *list, obj_t *init, obj_t *key)
{
  if (!key)
    key = identity_f;

  for (; list; list = cdr(list))
    init = funcall2(fun, init, funcall1(key, car(list)));

  return init;
}

obj_t *do_bind2(obj_t *fcons, obj_t *arg2)
{
  return funcall2(car(fcons), cdr(fcons), arg2);
}

obj_t *bind2(obj_t *fun2, obj_t *arg)
{
  return func_f1(cons(fun2, arg), do_bind2);
}

obj_t *do_bind2other(obj_t *fcons, obj_t *arg1)
{
  return funcall2(car(fcons), arg1, cdr(fcons));
}

obj_t *bind2other(obj_t *fun2, obj_t *arg2)
{
  return func_f1(cons(fun2, arg2), do_bind2other);
}


static obj_t *do_chain(obj_t *fun1_list, obj_t *arg)
{
  for (; fun1_list; fun1_list = cdr(fun1_list))
    arg = funcall1(car(fun1_list), arg);

  return arg;
}

obj_t *chain(obj_t *fun1_list)
{
  return func_f1(fun1_list, do_chain);
}

obj_t *vector(obj_t *alloc)
{
  long alloc_plus = c_num(alloc) + 2;
  obj_t *vec = make_obj();
  obj_t **v = chk_malloc(alloc_plus * sizeof *v);
  vec->v.type = VEC;
  vec->v.vec = v + 2;
  v[0] = alloc;
  v[1] = zero;
  return vec;
}

obj_t *vec_get_fill(obj_t *vec)
{
  assert (vec && vec->v.type == VEC);
  return vec->v.vec[vec_fill];
}

obj_t *vec_set_fill(obj_t *vec, obj_t *fill)
{
  assert (vec && vec->v.type == VEC);

  {
    long new_fill = c_num(fill);
    long old_fill = c_num(vec->v.vec[vec_fill]);
    long old_alloc = c_num(vec->v.vec[vec_alloc]);
    long fill_delta = new_fill - old_fill;
    long alloc_delta = new_fill - old_alloc;

    if (alloc_delta > 0) {
      long new_alloc = max(new_fill, 2*old_alloc);
      obj_t **newvec = chk_realloc(vec->v.vec - 2,
                                   (new_alloc + 2)*sizeof *newvec);
      vec->v.vec = newvec + 2;
      vec->v.vec[vec_alloc] = num(new_alloc);
    }

    if (fill_delta > 0) {
      long i;
      for (i = old_fill; i < new_fill; i++)
        vec->v.vec[i] = nil;
    }

    vec->v.vec[vec_fill] = fill;
  }

  return vec;
}


obj_t **vecref_l(obj_t *vec, obj_t *ind)
{
  assert (vec && vec->v.type == VEC);
  assert (c_num(ind) < c_num(vec->v.vec[vec_fill]));
  return vec->v.vec + c_num(ind);
}

obj_t *vec_push(obj_t *vec, obj_t *item)
{
  obj_t *fill = vec_get_fill(vec);
  vec_set_fill(vec, plus(fill, one));
  *vecref_l(vec, fill) = item;
  return fill;
}


static obj_t *stdio_line_read(struct stream *sm)
{
  if (sm->handle == 0) {
    return nil;
  } else {
    char *line = snarf_line((FILE *) sm->handle);

    if (!line)
      return nil;

    return string(line);
  }
}

static obj_t *stdio_line_write(struct stream *sm, obj_t *obj)
{
  assert (obj->t.type == STR);
  if (sm->handle == 0)
    return nil;
  if (fputs(c_str(obj), (FILE *) sm->handle) == EOF)
    return nil;
  if (putc('\n', (FILE *) sm->handle) == EOF)
    return nil;
  return t;
}

static obj_t *stdio_close(struct stream *sm)
{
  FILE *f = (FILE *) sm->handle;

  if (f != 0 && f != stdin && f != stdout) {
    fclose((FILE *) sm->handle);
    sm->handle = 0;
    return t;
  }
  return nil;
}

static struct stream_ops stdio_line_stream_ops = {
  stdio_line_read, stdio_line_write, stdio_close
};

obj_t *stdio_line_stream(FILE *f, obj_t *label)
{
  obj_t *sm = make_obj();
  sm->sm.type = STREAM;
  sm->sm.handle = f;
  sm->sm.ops = &stdio_line_stream_ops;
  sm->sm.label_pushback = label;
  assert (atom(label));
  return sm;
}

static obj_t *pipe_close(struct stream *sm)
{
  if (sm->handle != 0) {
    pclose((FILE *) sm->handle);
    sm->handle = 0;
    return t;
  }
  return nil;
}

static struct stream_ops pipe_line_stream_ops = {
  stdio_line_read, stdio_line_write, pipe_close
};

obj_t *pipe_line_stream(FILE *f, obj_t *label)
{
  obj_t *sm = make_obj();
  sm->sm.type = STREAM;
  sm->sm.handle = f;
  sm->sm.ops = &pipe_line_stream_ops;
  sm->sm.label_pushback = label;
  assert (atom(label));
  return sm;
}

obj_t *dirent_read(struct stream *sm)
{
  if (sm->handle == 0) {
    return nil;
  } else {
    for (;;) {
      struct dirent *e = readdir(sm->handle);
      if (!e)
        return nil;
      if (!strcmp(e->d_name, ".") || !strcmp(e->d_name, ".."))
        continue;
      return string(chk_strdup(e->d_name));
    }
  }
}

obj_t *dirent_close(struct stream *sm)
{
  if (sm->handle != 0) {
    closedir((DIR *) sm->handle);
    sm->handle = 0;
    return t;
  }

  return nil;
}

static struct stream_ops dirent_stream_ops = {
  dirent_read, 0, dirent_close
};

obj_t *dirent_stream(DIR *d, obj_t *label)
{
  obj_t *sm = make_obj();
  sm->sm.type = STREAM;
  sm->sm.handle = d;
  sm->sm.ops = &dirent_stream_ops;
  sm->sm.label_pushback = label;
  assert (atom(label));
  return sm;
}

obj_t *stream_get(obj_t *sm)
{
  assert (sm->sm.type == STREAM);

  if (consp(sm->sm.label_pushback)) {
    obj_t *ret = car(sm->sm.label_pushback);
    sm->sm.label_pushback = cdr(sm->sm.label_pushback);
    return ret;
  }

  return sm->sm.ops->read(&sm->sm);
}

obj_t *stream_pushback(obj_t *sm, obj_t *obj)
{
  assert (sm->sm.type == STREAM);
  sm->sm.label_pushback = cons(obj, sm->sm.label_pushback);
  return obj;
}

obj_t *stream_put(obj_t *sm, obj_t *obj)
{
  assert (sm->sm.type == STREAM);
  return sm->sm.ops->write(&sm->sm, obj);
}

obj_t *stream_close(obj_t *sm)
{
  assert (sm->sm.type == STREAM);
  return sm->sm.ops->close(&sm->sm);
}


static obj_t *make_lazycons(obj_t *func)
{
  obj_t *obj = make_obj();
  obj->lc.type = LCONS;
  obj->lc.car = obj->lc.cdr = nil;
  obj->lc.func = func;
  return obj;
}

static obj_t *lazy_stream_func(obj_t *stream, obj_t *lcons)
{
  obj_t *next = stream_get(stream);
  obj_t *ahead = stream_get(stream);

  lcons->lc.car = next;
  lcons->lc.cdr = if2(ahead, make_lazycons(lcons->lc.func));
  lcons->lc.func = nil;

  if (!next || !ahead)
    stream_close(stream);

  if (ahead)
    stream_pushback(stream, ahead);

  return next;
}

obj_t *lazy_stream_cons(obj_t *stream)
{
  obj_t *first = stream_get(stream);

  if (!first) {
    stream_close(stream);
    return nil;
  }

  stream_pushback(stream, first);

  return make_lazycons(func_f1(stream, lazy_stream_func));
}

obj_t *cobj(void *handle, obj_t *cls_sym, struct cobj_ops *ops)
{
  obj_t *obj = make_obj();
  obj->co.type = COBJ;
  obj->co.handle = handle;
  obj->co.ops = ops;
  obj->co.cls = cls_sym;
  return obj;
}

void cobj_print_op(obj_t *obj, FILE *out)
{
  fprintf(out, "#<");
  obj_print(obj->co.cls, out);
  fprintf(out, ": %p>", obj->co.handle);
}

obj_t *assoc(obj_t *list, obj_t *key)
{
  while (list) {
    obj_t *elem = car(list);
    if (equal(car(elem), key))
      return elem;
    list = cdr(list);
  }

  return nil;
}

obj_t *acons_new(obj_t *list, obj_t *key, obj_t *value)
{
  obj_t *existing = assoc(list, key);

  if (existing) {
    *cdr_l(existing) = value;
    return list;
  } else {
    return cons(cons(key, value), list);
  }
}

obj_t *alist_remove(obj_t *list, obj_t *keys)
{
  obj_t **plist = &list;

  while (*plist) {
    if (memq(car(car(*plist)), keys))
      *plist = cdr(*plist);
    else
      plist = cdr_l(*plist);
  }

  return list;
}

obj_t *mapcar(obj_t *fun, obj_t *list)
{
  list_collect_decl (out, iter);

  for (; list; list = cdr(list))
    list_collect (iter, funcall1(fun, car(list)));

  return out;
}

obj_t *mappend(obj_t *fun, obj_t *list)
{
  list_collect_decl (out, iter);

  for (; list; list = cdr(list))
    list_collect_append (iter, funcall1(fun, car(list)));

  return out;
}

obj_t *merge(obj_t *list1, obj_t *list2, obj_t *lessfun, obj_t *keyfun)
{
  list_collect_decl (out, ptail);

  while (list1 && list2) {
    obj_t *el1 = funcall1(keyfun, first(list1));
    obj_t *el2 = funcall1(keyfun, first(list2));

    if (funcall2(lessfun, el1, el2)) {
      obj_t *next = cdr(list1);
      *cdr_l(list1) = nil;
      list_collect_append(ptail, list1);
      list1 = next;
    } else {
      obj_t *next = cdr(list2);
      *cdr_l(list2) = nil;
      list_collect_append(ptail, list2);
      list2 = next;
    }
  }

  if (list1)
    list_collect_append(ptail, list1);
  else
    list_collect_append(ptail, list2);

  return out;
}

static obj_t *do_sort(obj_t *list, obj_t *lessfun, obj_t *keyfun)
{
  if (list == nil)
    return nil;
  if (!cdr(list))
    return list;
  if (!cdr(cdr(list))) {
    if (funcall2(lessfun, funcall1(keyfun, first(list)),
                          funcall1(keyfun, second(list))))
    {
      return list;
    } else {
      obj_t *cons2 = cdr(list);
      *cdr_l(cons2) = list;
      *cdr_l(list) = nil;
      return cons2;
    }
  }

  {
    obj_t *bisect, *iter;
    obj_t *list2;

    for (iter = cdr(cdr(list)), bisect = list; iter;
         bisect = cdr(bisect), iter = cdr(cdr(iter)))
      ; /* empty */

    list2 = cdr(bisect);
    *cdr_l(bisect) = nil;

    return merge(sort(list, lessfun, keyfun),
                 sort(list2, lessfun, keyfun),
                 lessfun, keyfun);
  }
}

obj_t *sort(obj_t *list, obj_t *lessfun, obj_t *keyfun)
{
  if (!keyfun)
    keyfun = identity_f;

  return do_sort(list, lessfun, keyfun);
}

static void obj_init(void)
{
  int gc_save = gc_state(0);

  /*
   * No need to GC-protect the convenience variables which hold the interned
   * symbols, because the interned_syms list holds a reference to all the
   * symbols.
   */

  protect(&interned_syms, &zero, &one,
          &two, &negone, &maxint, &minint,
          &null_string, &nil_string,
          &null_list, &equal_f,
          &identity_f, 0);

  null = intern(string(strdup("null")));
  t = intern(string(strdup("t")));
  cons_t = intern(string(strdup("cons")));
  str_t = intern(string(strdup("str")));
  chr_t = intern(string(strdup("chr")));
  num_t = intern(string(strdup("num")));
  sym_t = intern(string(strdup("sym")));
  fun_t = intern(string(strdup("fun")));
  vec_t = intern(string(strdup("vec")));
  stream_t = intern(string(strdup("stream")));
  lcons_t = intern(string(strdup("lcons")));
  var = intern(string(strdup("var")));
  regex = intern(string(strdup("regex")));
  set = intern(string(strdup("set")));
  cset = intern(string(strdup("cset")));
  wild = intern(string(strdup("wild")));
  oneplus = intern(string(strdup("1+")));
  zeroplus = intern(string(strdup("0+")));
  optional = intern(string(strdup("?")));
  compound = intern(string(strdup("compound")));
  or = intern(string(strdup("or")));
  skip = intern(string(strdup("skip")));
  trailer = intern(string(strdup("trailer")));
  block = intern(string(strdup("block")));
  next = intern(string(strdup("next")));
  fail = intern(string(strdup("fail")));
  accept = intern(string(strdup("accept")));
  all = intern(string(strdup("all")));
  some = intern(string(strdup("some")));
  none = intern(string(strdup("none")));
  maybe = intern(string(strdup("maybe")));
  collect = intern(string(strdup("collect")));
  until = intern(string(strdup("until")));
  coll = intern(string(strdup("coll")));
  output = intern(string(strdup("output")));
  single = intern(string(strdup("single")));
  frst = intern(string(strdup("first")));
  lst = intern(string(strdup("last")));
  empty = intern(string(strdup("empty")));
  repeat = intern(string(strdup("repeat")));
  rep = intern(string(strdup("rep")));
  flattn = intern(string(strdup("flatten")));
  forget = intern(string(strdup("forget")));
  mrge = intern(string(strdup("merge")));
  bind = intern(string(strdup("bind")));
  cat = intern(string(strdup("cat")));
  dir = intern(string(strdup("dir")));

  zero = num(0);
  one  = num(1);
  two = num(2);
  negone = num(-1);
  maxint = num(LONG_MAX);
  minint = num(LONG_MIN);

  null_string = string(strdup(""));
  nil_string = string(strdup("NIL"));

  null_list = cons(nil, nil);

  equal_f = func_f2(nil, equal_tramp);
  identity_f = func_f1(nil, identity_tramp);

  gc_state(gc_save);
}

void obj_print(obj_t *obj, FILE *out)
{
  if (obj == nil) {
    fputs("nil", out);
    return;
  }

  switch (obj->t.type) {
  case CONS:
  case LCONS:
    {
      obj_t *iter;
      putc('(', out);
      for (iter = obj; consp(iter); iter = cdr(iter)) {
        obj_print(car(iter), out);
        if (nullp(cdr(iter))) {
          putc(')', out);
        } else if (consp(cdr(iter))) {
          putc(' ', out);
        } else {
          fputs(" . ", out);
          obj_print(cdr(iter), out);
          putc(')', out);
        }
      }
    }
    break;
  case STR:
    {
      const char *ptr;
      putc('"', out);
      for (ptr = obj->st.str; *ptr; ptr++) {
        switch (*ptr) {
        case '\a': fputs("\\a", out); break;
        case '\b': fputs("\\b", out); break;
        case '\t': fputs("\\t", out); break;
        case '\n': fputs("\\n", out); break;
        case '\v': fputs("\\v", out); break;
        case '\f': fputs("\\f", out); break;
        case '\r': fputs("\\r", out); break;
        case '"': fputs("\\\"", out); break;
        case '\\': fputs("\\\\", out); break;
        case 27: fputs("\\e", out); break;
        default:
          if (iscntrl(*ptr))
            fprintf(out, "\\%03o", (int) *ptr);
          else
            putc(*ptr, out);
        }
      }
      putc('"', out);
    }
    break;
  case CHR:
    {
      int ch = obj->ch.ch;

      putc('\'', out);
      switch (ch) {
      case '\a': fputs("\\a", out); break;
      case '\b': fputs("\\b", out); break;
      case '\t': fputs("\\t", out); break;
      case '\n': fputs("\\n", out); break;
      case '\v': fputs("\\v", out); break;
      case '\f': fputs("\\f", out); break;
      case '\r': fputs("\\r", out); break;
      case '"': fputs("\\\"", out); break;
      case '\\': fputs("\\\\", out); break;
      case 27: fputs("\\e", out); break;
      default:
        if (iscntrl(ch))
          fprintf(out, "\\%03o", ch);
        else
          putc(ch, out);
      }
      putc('\'', out);
    }
    break;
  case NUM:
    fprintf(out, "%ld", c_num(obj));
    break;
  case SYM:
    fputs(c_str(symbol_name(obj)), out);
    break;
  case FUN:
    fprintf(out, "#<function: f%d>", (int) obj->f.functype);
    break;
  case VEC:
    {
      long i, fill = c_num(obj->v.vec[vec_fill]);
      fputs("#(", out);
      for (i = 0; i < fill; i++) {
        obj_print(obj->v.vec[i], out);
        if (i < fill - 1)
          putc(' ', out);
      }
      putc(')', out);
    }
    break;
  case STREAM:
    fprintf(out, "#<stream: ");
    {
      obj_t *iter;
      /* skip stream pushback items to find label */
      for (iter = obj->sm.label_pushback; consp(iter); iter = cdr(iter))
        ;
      obj_print(iter, out);
    }
    fprintf(out, ", %p>", (void *) obj->sm.handle);
    break;
  case COBJ:
    obj->co.ops->print(obj, out);
    break;
  }
}

void init(const char *pn, void *(*oom)(void *, size_t),
          obj_t **maybe_bottom_0, obj_t **maybe_bottom_1)
{
  int growsdown;
  obj_t *local_bottom = nil;
  progname = pn;

  /* If the local_bottom variable has a smaller address than
     either of the two possible top variables from
     the initializing function, then the stack grows
     downward in memory. In that case, we take the
     greater of the two values to be the top.
     Otherwise we take the smaller of the two values. */

  growsdown = &local_bottom < maybe_bottom_0;

  gc_init(growsdown
          ? max(maybe_bottom_0, maybe_bottom_1)
          : min(maybe_bottom_0, maybe_bottom_1));

  obj_init();
}

void dump(obj_t *obj, FILE *out)
{
  obj_print(obj, out);
  putc('\n', out);
}

/*
 * Handy function for debugging in gdb,
 * so we don't have to keep typing:
 * (gdb) p dump(something, stdout)
 */
void d(obj_t *obj)
{
  dump(obj, stdout);
}

char *snarf_line(FILE *in)
{
  const size_t min_size = 512;
  size_t size = 0;
  size_t fill = 0;
  char *buf = 0;

  for (;;) {
    int ch = getc(in);

    if (ch == EOF && buf == 0)
      break;

    if (fill >= size) {
      size_t newsize = size ? size * 2 : min_size;
      buf = chk_realloc(buf, newsize);
      size = newsize;
    }

    if (ch == '\n') {
      buf[fill++] = 0;
      break;
    }
    buf[fill++] = ch;
  }

  if (buf)
    buf = chk_realloc(buf, fill);

  return buf;
}

obj_t *snarf(FILE *in)
{
  list_collect_decl (list, iter);
  char *str;

  while ((str = snarf_line(in)) != 0)
    list_collect (iter, string(str));

  return list;
}