oats/lisp/lisp.c

/* Copyright (C) 2025 Aryadev Chavali

 * This program is distributed in the hope that it will be useful, but WITHOUT
 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
 * FOR A PARTICULAR PURPOSE.  See the GNU General Public License Version 2 for
 * details.

 * You may distribute and modify this code under the terms of the GNU General
 * Public License Version 2, which you should have received a copy of along with
 * this program.  If not, please go to <https://www.gnu.org/licenses/>.

 * Created: 2025-04-06
 * Description:
 */

#include <lib/sv.h>
#include <lisp/lisp.h>

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

lisp_t *make_int(i64 integer)
{
  return tag_int(integer);
}

lisp_t *make_sym(context_t *ctx, char *data, u64 size)
{
  // Small symbol optimisation
  if (size <= 7)
    return tag_ssym(data, size);

  // Make a cell with the data we need
  cell_t *cell = context_alloc(ctx, sizeof(*cell) + size);
  cell->size   = size;
  memcpy(cell->data, data, size);

  return tag_sym(cell);
}

lisp_t *make_cons(context_t *ctx, lisp_t *car, lisp_t *cdr)
{
  cons_t *cons = context_alloc(ctx, sizeof(*cons));
  memset(cons, 0, sizeof(*cons));
  cons->car = car;
  cons->cdr = cdr;
  return tag_cons(cons);
}

lisp_t *make_list(context_t *ctx, lisp_t **lisps, u64 size)
{
  if (!lisps)
    return NIL;
  lisp_t *cur = NIL;
  for (u64 i = size; i > 0; --i)
    cur = make_cons(ctx, lisps[i - 1], cur);
  return cur;
}

lisp_t *make_vec(context_t *ctx, u32 size)
{
  // Make a vector with the content
  lisp_t *container = NIL;
  vec_t *vec        = context_alloc(ctx, sizeof(*vec));
  vec->size         = 0;
  vec->cap          = size * sizeof(&container);
  if (size == 0)
    vec->data = NULL;
  else
    vec->data = context_alloc(ctx, vec->cap);
  container = tag_vec(vec);

  return container;
}

lisp_t *make_str(context_t *ctx, char *data, u64 size)
{
  if (size == 0)
    // No need to allocate unless necessary
    return tag_str(NIL);
  // Make a vector with the content
  vec_t *vec = context_alloc(ctx, sizeof(*vec));
  vec->data  = context_alloc(ctx, sizeof(*vec->data) * size);
  vec->cap   = size;
  vec->size  = size;
  memcpy(vec->data, data, size);

  return tag_str(vec);
}

i64 as_int(lisp_t *obj)
{
  assert(IS_TAG(obj, INT));
  u64 p_obj = (u64)obj;
  return UNTAG(p_obj, INT) |               // Delete the tag
         (NTH_BYTE(p_obj, 7) & 0x80) << 56 // duplicate the MSB (preserve sign)
      ;
}

cons_t *as_cons(lisp_t *obj)
{
  assert(IS_TAG(obj, CONS));
  return (cons_t *)UNTAG(obj, CONS);
}

u32 as_char(lisp_t *obj)
{
  return (u32)UNTAG(obj, CHAR);
}

cell_t *as_sym(lisp_t *obj)
{
  assert(IS_TAG(obj, SYM));
  return (cell_t *)UNTAG(obj, SYM);
}

void as_ssym(lisp_t *obj, sv_t *container)
{
  assert(IS_TAG(obj, SSYM));
  u64 p_obj       = (u64)obj;
  container->size = NTH_BYTE(p_obj, 0) >> SHIFT_SSYM;
  p_obj >>= 8;
  memcpy(container->data, &p_obj, container->size);
}

bool as_bool(lisp_t *obj)
{
  assert(IS_TAG(obj, BOOL));
  return (bool)UNTAG(obj, BOOL);
}

f64 as_float(lisp_t *obj)
{
  assert(IS_TAG(obj, FLOAT));
  f64 *f = (f64 *)UNTAG(obj, FLOAT);
  return f ? *f : 0;
}

vec_t *as_vec(lisp_t *obj)
{
  assert(IS_TAG(obj, VEC));
  return (vec_t *)UNTAG(obj, VEC);
}

vec_t *as_str(lisp_t *obj)
{
  assert(IS_TAG(obj, STR));
  return (vec_t *)UNTAG(obj, STR);
}

sv_t serialise(context_t *ctx, lisp_t *ptr)
{
  enum Tag t = tag_get(ptr);
  switch (t)
  {
  case TAG_NIL:
  {
    return SV("NIL", 3);
  }
  case TAG_INT:
  {
    i64 i  = as_int(ptr);
    sv_t s = sv_fmt(&ctx->scratch,
#if DEBUG > 1
                    "int["
#endif
                    "%ld"
#if DEBUG > 1
                    "]"
#endif
                    ,
                    i);
    return s;
  }
  case TAG_CHAR:
  {
    u32 codepoint = as_char(ptr);
    return sv_fmt(&ctx->scratch,
#if DEBUG > 1
                  "char["
#endif
                  "%lc"
#if DEBUG > 1
                  "]"
#endif
                  ,
                  codepoint);
  }
  case TAG_SYM:
  {
    cell_t *cell = as_sym(ptr);
    sv_t s       = sv_make(&ctx->scratch, (char *)cell->data, cell->size);
#if DEBUG > 1
    s = sv_fmt(&ctx->scratch, "sym[" PR_SV "]", SV_FMT(s));
#endif
    return s;
  }
  case TAG_SSYM:
  {
    char data[7];
    sv_t rsym = SV(data, 0);
    as_ssym(ptr, &rsym);
    sv_t s = sv_copy(&ctx->scratch, rsym);

#if DEBUG > 1
    s = sv_fmt(&ctx->scratch, "ssym[" PR_SV "]", SV_FMT(s));
#endif
    return s;
  }
  case TAG_BOOL:
  {
    return sv_fmt(&ctx->scratch,
#if DEBUG > 1
                  "bool["
#endif
                  "%s"
#if DEBUG > 1
                  "]"
#endif
                  ,
                  as_bool(ptr) ? "#t" : "#f");
  }
  case TAG_FLOAT:
  {
    return sv_fmt(&ctx->scratch,
#if DEBUG > 1
                  "float["
#endif
                  "%lf"
#if DEBUG > 1
                  "]"
#endif
                  ,
                  as_float(ptr));
  }
  case TAG_CONS:
  {
    if (!CAR(ptr) && !CDR(ptr))
#if DEBUG > 1
      return SV("lst[NIL]", 8);
#else
      return SV("NIL", 3);
#endif

    sv_t s = {0};

    for (lisp_t *lsp = ptr; lsp; lsp = IS_TAG(lsp, CONS) ? CDR(lsp) : NIL)
    {
      lisp_t *lmember = lsp;
      if (IS_TAG(lsp, CONS))
        lmember = CAR(lmember);

      sv_t member = serialise(ctx, lmember);
      s           = sv_concat(&ctx->scratch, s, member);
      if (IS_TAG(lsp, CONS) && !CDR(lsp))
        continue;
      else if (IS_TAG(CDR(lsp), CONS))
        // normal list
        s = sv_append(&ctx->scratch, s, " ", 1);
      else
        // dotted list
        s = sv_append(&ctx->scratch, s, " . ", 3);
    }

#if DEBUG > 1
    s = sv_fmt(&ctx->scratch, "lst[" PR_SV "]", SV_FMT(s));
#else
    s = sv_fmt(&ctx->scratch, "(" PR_SV ")", SV_FMT(s));
#endif
    return s;
  }
  case TAG_VEC:
  {
    vec_t *vec = as_vec(ptr);
    if (!vec)
#if DEBUG > 1
      return SV("vec[NIL]", 8);
#else
      return SV("#()", 3);
#endif
    else if (vec->size < sizeof(&ptr))
#if DEBUG > 1
      return SV("vec[0/0 #()]", 13);
#else
      return SV("#()", 3);
#endif

    sv_t s = {0};
    for (u64 i = 0; i < vec->size / sizeof(&ptr); ++i)
    {
      lisp_t *lmember = ((lisp_t **)vec->data)[i];
      sv_t member     = serialise(ctx, lmember);
      s               = sv_concat(&ctx->scratch, s, member);
      if (i == ((vec->size / sizeof(&ptr)) - 1))
        continue;
      s = sv_append(&ctx->scratch, s, " ", 1);
    }

#if DEBUG > 1
    s = sv_fmt(&ctx->scratch, "vec[%lu/%lu #(" PR_SV ")]", vec->size, vec->cap,
               SV_FMT(s));
#else
    s = sv_fmt(&ctx->scratch, "#(" PR_SV ")", SV_FMT(s));
#endif
    return s;
    break;
  }
  case TAG_STR:
  {
    vec_t *vec = as_str(ptr);
    sv_t sv    = {0};
    if (vec)
      sv = SV((char *)vec->data, vec->size);
    else
      sv = SV("", 0);
    return sv_fmt(&ctx->scratch,
#if DEBUG > 1
                  "str["
#else
                  "\""
#endif
                  PR_SV
#if DEBUG > 1
                  "]"
#else
                  "\""
#endif
                  ,
                  SV_FMT(sv));
  }
  case NUM_TAGS:
  default:
    assert(false && "serialise: unreachable");
    return SV(0, 0);
  }
}