kmx git

/* kc3
 * Copyright 2022,2023,2024 kmx.io <contact@kmx.io>
 *
 * Permission is hereby granted to use this software granted the above
 * copyright notice and this permission paragraph are included in all
 * copies and substantial portions of this software.
 *
 * THIS SOFTWARE IS PROVIDED "AS-IS" WITHOUT ANY GUARANTEE OF
 * PURPOSE AND PERFORMANCE. IN NO EVENT WHATSOEVER SHALL THE
 * AUTHOR BE CONSIDERED LIABLE FOR THE USE AND PERFORMANCE OF
 * THIS SOFTWARE.
 */
#include <string.h>
#include "alloc.h"
#include "array.h"
#include "assert.h"
#include "block.h"
#include "buf.h"
#include "buf_inspect.h"
#include "buf_parse.h"
#include "call.h"
#include "cfn.h"
#include "compare.h"
#include "cow.h"
#include "env.h"
#include "fn.h"
#include "frame.h"
#include "hash.h"
#include "ident.h"
#include "integer.h"
#include "list.h"
#include "map.h"
#include "pcomplex.h"
#include "pcow.h"
#include "ptr.h"
#include "ptr_free.h"
#include "quote.h"
#include "ratio.h"
#include "str.h"
#include "struct.h"
#include "struct_type.h"
#include "sym.h"
#include "tag.h"
#include "tag_type.h"
#include "time.h"
#include "tuple.h"
#include "unquote.h"
#include "var.h"

s_tag g_tag_first;
s_tag g_tag_last;

s_tag * tag_1 (s_tag *tag, const char *p)
{
  tag_clean(tag);
  return tag_init_1(tag, p);
}

bool * tag_and (const s_tag *a, const s_tag *b, bool *dest)
{
  s_tag f;
  assert(a);
  assert(b);
  assert(dest);
  tag_init_bool(&f, false);
  *dest = compare_tag(a, &f) != 0 && compare_tag(b, &f) != 0 ? 1 : 0;
  return dest;
}

s8 tag_arity (const s_tag *tag)
{
  switch (tag->type) {
  case TAG_CFN: return cfn_arity(&tag->data.cfn);
  case TAG_FN:  return fn_arity(&tag->data.fn);
  default:
    break;
  }
  return -1;
}

s_tag * tag_cast_integer_to_s8 (s_tag *tag)
{
  s8 i;
  assert(tag);
  assert(tag->type == TAG_INTEGER);
  i = integer_to_s8(&tag->data.integer);
  return tag_s8(tag, i);
}

s_tag * tag_cast_integer_to_s16 (s_tag *tag)
{
  s16 i;
  assert(tag);
  assert(tag->type == TAG_INTEGER);
  i = integer_to_s16(&tag->data.integer);
  return tag_s16(tag, i);
}

s_tag * tag_cast_integer_to_s32 (s_tag *tag)
{
  s32 i;
  assert(tag);
  assert(tag->type == TAG_INTEGER);
  i = integer_to_s32(&tag->data.integer);
  return tag_s32(tag, i);
}

s_tag * tag_cast_integer_to_s64 (s_tag *tag)
{
  s64 i;
  assert(tag);
  assert(tag->type == TAG_INTEGER);
  i = integer_to_s64(&tag->data.integer);
  return tag_s64(tag, i);
}

s_tag * tag_cast_integer_to_u8 (s_tag *tag)
{
  u8 i;
  assert(tag);
  assert(tag->type == TAG_INTEGER);
  i = integer_to_u8(&tag->data.integer);
  return tag_u8(tag, i);
}

s_tag * tag_cast_integer_to_u16 (s_tag *tag)
{
  u16 i;
  assert(tag);
  assert(tag->type == TAG_INTEGER);
  i = integer_to_u16(&tag->data.integer);
  return tag_u16(tag, i);
}

s_tag * tag_cast_integer_to_u32 (s_tag *tag)
{
  u32 i;
  assert(tag);
  assert(tag->type == TAG_INTEGER);
  i = integer_to_u32(&tag->data.integer);
  return tag_u32(tag, i);
}

s_tag * tag_cast_integer_to_u64 (s_tag *tag)
{
  u64 i;
  assert(tag);
  assert(tag->type == TAG_INTEGER);
  i = integer_to_u64(&tag->data.integer);
  return tag_u64(tag, i);
}

void tag_clean (s_tag *tag)
{
  assert(tag);
  switch (tag->type) {
  case TAG_ARRAY:       array_clean(&tag->data.array);      break;
  case TAG_BLOCK:       block_clean(&tag->data.block);      break;
  case TAG_CALL:        call_clean(&tag->data.call);        break;
  case TAG_CFN:         cfn_clean(&tag->data.cfn);          break;
  case TAG_COMPLEX:     pcomplex_clean(&tag->data.complex); break;
  case TAG_COW:         pcow_clean(&tag->data.cow);         break;
  case TAG_FN:          fn_clean(&tag->data.fn);            break;
  case TAG_INTEGER:     integer_clean(&tag->data.integer);  break;
  case TAG_LIST:        list_delete_all(tag->data.list);    break;
  case TAG_MAP:         map_clean(&tag->data.map);          break;
  case TAG_PTR_FREE:    ptr_free_clean(&tag->data.ptr);     break;
  case TAG_QUOTE:       quote_clean(&tag->data.quote);      break;
  case TAG_RATIO:       ratio_clean(&tag->data.ratio);      break;
  case TAG_STR:         str_clean(&tag->data.str);          break;
  case TAG_STRUCT:      struct_clean(&tag->data.struct_);   break;
  case TAG_STRUCT_TYPE: struct_type_clean(&tag->data.struct_type);
                                                            break;
  case TAG_TUPLE:       tuple_clean(&tag->data.tuple);      break;
  case TAG_UNQUOTE:     unquote_clean(&tag->data.unquote);  break;
  case TAG_BOOL:
  case TAG_CHARACTER:
  case TAG_F32:
  case TAG_F64:
  case TAG_F128:
  case TAG_FACT:
  case TAG_IDENT:
  case TAG_PTAG:
  case TAG_PTR:
  case TAG_S8:
  case TAG_S16:
  case TAG_S32:
  case TAG_S64:
  case TAG_SW:
  case TAG_SYM:
  case TAG_U8:
  case TAG_U16:
  case TAG_U32:
  case TAG_U64:
  case TAG_UW:
  case TAG_VAR:
  case TAG_VOID:
    break;
  }
}

s_tag * tag_brackets (const s_tag *tag, const s_tag *address,
                      s_tag *dest)
{
  assert(tag);
  assert(address);
  assert(dest);
  switch (tag->type) {
  case TAG_ARRAY:
    switch (address->type) {
    case TAG_ARRAY:
      return array_data_tag(tag, address, dest);
    default:
      break;
    }
  default:
    break;
  }
  err_puts("tag_brackets: invalid arguments");
  assert(! "tag_brackets: invalid arguments");
  return NULL;
}

void tag_delete (s_tag *tag)
{
  tag_clean(tag);
  free(tag);
}

bool * tag_eq (const s_tag *a, const s_tag *b, bool *dest)
{
  assert(a);
  assert(b);
  assert(dest);
  *dest = compare_tag(a, b) == 0 ? 1 : 0;
  return dest;
}

s_tag * tag_equal (const s_tag *a, const s_tag *b, s_tag *dest)
{
  assert(a);
  assert(b);
  assert(dest);
  if (! env_eval_equal_tag (&g_kc3_env, false, a, b, dest))
    return NULL;
  return dest;
}

bool * tag_gt (const s_tag *a, const s_tag *b, bool *dest)
{
  assert(a);
  assert(b);
  assert(dest);
  *dest = compare_tag(a, b) > 0 ? 1 : 0;
  return dest;
}

bool * tag_gte (const s_tag *a, const s_tag *b, bool *dest)
{
  assert(a);
  assert(b);
  assert(dest);
  *dest = compare_tag(a, b) >= 0 ? 1 : 0;
  return dest;
}

u64 * tag_hash_u64 (const s_tag *tag, u64 *dest)
{
  t_hash hash;
  assert(tag);
  hash_init(&hash);
  if (! hash_update_tag(&hash, tag))
    return NULL;
  *dest = hash_to_u64(&hash);
  return dest;
}

uw * tag_hash_uw (const s_tag *tag, uw *dest)
{
  t_hash hash;
  assert(tag);
  hash_init(&hash);
  if (! hash_update_tag(&hash, tag)) {
    err_write_1("tag_hash_uw: hash_update_tag: ");
    err_inspect_tag(tag);
    err_write_1("\n");
    assert(! "tag_hash_uw: hash_update_tag");
    return NULL;
  }
  *dest = hash_to_uw(&hash);
  return dest;
}

bool tag_ident_is_bound (const s_tag *tag)
{
  return env_tag_ident_is_bound(&g_kc3_env, tag);
}

s_tag * tag_init (s_tag *tag)
{
  *tag = (s_tag) {0};
  return tag;
}

s_tag * tag_init_1 (s_tag *tag, const char *p)
{
  s_buf buf;
  uw len;
  sw r;
  assert(tag);
  tag_init_void(tag);
  if (! p)
    return tag;
  len = strlen(p);
  buf_init(&buf, false, len, (char *) p); // buf is read-only
  buf.wpos = len;
  r = buf_parse_tag(&buf, tag);
  if (r < 0 || (uw) r != len) {
    err_write_1("invalid tag: \"");
    err_write_1(p);
    err_write_1("\", ");
    err_inspect_uw(&len);
    err_write_1(" != ");
    err_inspect_sw(&r);
    assert(! "invalid tag");
    return NULL;
  }
  return tag;
}

s_tag * tag_init_call_cast (s_tag *tag, const s_sym *type)
{
  s_tag tmp = {0};
  tmp.type = TAG_CALL;
  if (! call_init_call_cast(&tmp.data.call, type))
    return NULL;
  *tag = tmp;
  return tag;
}

s_tag * tag_init_copy (s_tag *tag, const s_tag *src)
{
  assert(tag);
  assert(src);
  switch (src->type) {
  case TAG_ARRAY:
    tag->type = src->type;
    if (! array_init_copy(&tag->data.array, &src->data.array))
      return NULL;
    return tag;
  case TAG_BOOL:
    tag->type = src->type;
    tag->data.bool = src->data.bool;
    return tag;
  case TAG_BLOCK:
    tag->type = src->type;
    if (! block_init_copy(&tag->data.block, &src->data.block))
      return NULL;
    return tag;
  case TAG_CALL:
    tag->type = src->type;
    if (! call_init_copy(&tag->data.call, &src->data.call))
      return NULL;
    return tag;
  case TAG_CFN:
    tag->type = src->type;
    if (! cfn_init_copy(&tag->data.cfn, &src->data.cfn))
      return NULL;
    return tag;
  case TAG_CHARACTER:
    tag->type = src->type;
    tag->data.character = src->data.character;
    return tag;
  case TAG_COMPLEX:
    tag->type = src->type;
    if (! pcomplex_init_copy(&tag->data.complex,
                             (const s_complex * const *)
                             &src->data.complex))
      return NULL;
    return tag;
  case TAG_COW:
    tag->type = src->type;
    if (! pcow_init_copy(&tag->data.cow,
                         (const s_cow * const *) &src->data.cow))
      return NULL;
    return tag;
  case TAG_F32:
    tag->type = src->type;
    tag->data.f32 = src->data.f32;
    return tag;
  case TAG_F64:
    tag->type = src->type;
    tag->data.f64 = src->data.f64;
    return tag;
  case TAG_F128:
    tag->type = src->type;
    tag->data.f128 = src->data.f128;
    return tag;
  case TAG_FACT:
    tag->type = src->type;
    tag->data.fact = src->data.fact;
    return tag;
  case TAG_FN:
    tag->type = src->type;
    if (! fn_init_copy(&tag->data.fn, &src->data.fn))
      return NULL;
    return tag;
  case TAG_IDENT:
    tag->type = src->type;
    tag->data.ident = src->data.ident;
    return tag;
  case TAG_INTEGER:
    tag->type = src->type;
    if (! integer_init_copy(&tag->data.integer, &src->data.integer))
      return NULL;
    return tag;
  case TAG_LIST:
    tag->type = src->type;
    if (! list_init_copy(&tag->data.list,
                         (const s_list * const *)
                         &src->data.list))
      return NULL;
    return tag;
  case TAG_MAP:
    tag->type = src->type;
    if (! map_init_copy(&tag->data.map, &src->data.map))
      return NULL;
    return tag;
  case TAG_PTAG:
    tag->type = src->type;
    tag->data.ptag = src->data.ptag;
    return tag;
  case TAG_PTR:
    tag->type = src->type;
    tag->data.ptr = src->data.ptr;
    return tag;
  case TAG_PTR_FREE:
    tag->type = src->type;
    tag->data.ptr_free = src->data.ptr_free;
    return tag;
  case TAG_QUOTE:
    tag->type = src->type;
    if (! quote_init_copy(&tag->data.quote, &src->data.quote))
      return NULL;
    return tag;
  case TAG_RATIO:
    tag->type = src->type;
    if (! ratio_init_copy(&tag->data.ratio, &src->data.ratio))
      return NULL;
    return tag;
  case TAG_S8:
    tag->type = src->type;
    tag->data.s8 = src->data.s8;
    return tag;
  case TAG_S16:
    tag->type = src->type;
    tag->data.s16 = src->data.s16;
    return tag;
  case TAG_S32:
    tag->type = src->type;
    tag->data.s32 = src->data.s32;
    return tag;
  case TAG_S64:
    tag->type = src->type;
    tag->data.s64 = src->data.s64;
    return tag;
  case TAG_STR:
    tag->type = src->type;
    if (! str_init_copy(&tag->data.str, &src->data.str))
      return NULL;
    return tag;
  case TAG_STRUCT:
    tag->type = src->type;
    if (! struct_init_copy(&tag->data.struct_, &src->data.struct_))
      return NULL;
    return tag;
  case TAG_STRUCT_TYPE:
    tag->type = src->type;
    if (! struct_type_init_copy(&tag->data.struct_type,
                                &src->data.struct_type))
      return NULL;
    return tag;
  case TAG_SW:
    tag->type = src->type;
    tag->data.sw = src->data.sw;
    return tag;
  case TAG_SYM:
    tag->type = src->type;
    tag->data.sym = src->data.sym;
    return tag;
  case TAG_TUPLE:
    tag->type = src->type;
    if (! tuple_init_copy(&tag->data.tuple, &src->data.tuple))
      return NULL;
    return tag;
  case TAG_UNQUOTE:
    tag->type = src->type;
    if (! unquote_init_copy(&tag->data.unquote, &src->data.unquote))
      return NULL;
    return tag;
  case TAG_U8:
    tag->type = src->type;
    tag->data.u8 = src->data.u8;
    return tag;
  case TAG_U16:
    tag->type = src->type;
    tag->data.u16 = src->data.u16;
    return tag;
  case TAG_U32:
    tag->type = src->type;
    tag->data.u32 = src->data.u32;
    return tag;
  case TAG_U64:
    tag->type = src->type;
    tag->data.u64 = src->data.u64;
    return tag;
  case TAG_UW:
    tag->type = src->type;
    tag->data.uw = src->data.uw;
    return tag;
  case TAG_VAR:
    tag->type = src->type;
    if (! var_init_copy(tag, src))
      return NULL;
    return tag;
  case TAG_VOID:
    tag_init_void(tag);
    return tag;
  }
  err_puts("tag_init_copy: invalid tag type");
  assert(! "tag_init_copy: invalid tag type");
  return NULL;
}

s_tag * tag_init_time (s_tag *tag)
{
  s_time time;
  clock_gettime(CLOCK_REALTIME, &time);
  return time_to_tag(&time, tag);
}

s_tag * tag_integer_reduce (s_tag *tag)
{
  s_integer *i;
  s_integer j;
  static s_integer s8_min = {0};
  static s_integer s16_min = {0};
  static s_integer s32_min = {0};
  static s_integer s64_min = {0};
  static s_integer u8_max = {0};
  static s_integer u16_max = {0};
  static s_integer u32_max = {0};
  static s_integer u64_max = {0};
  static s_integer zero = {0};
  assert(tag);
  if (s8_min.mp_int.sign != MP_NEG) {
    integer_init_s8(&s8_min, S8_MIN);
    integer_init_s16(&s16_min, S16_MIN);
    integer_init_s32(&s32_min, S32_MIN);
    integer_init_s64(&s64_min, S64_MIN);
    integer_init_u8(&u8_max, U8_MAX);
    integer_init_u16(&u16_max, U16_MAX);
    integer_init_u32(&u32_max, U32_MAX);
    integer_init_u64(&u64_max, U64_MAX);
    integer_init_u8(&zero, 0);
  }
  switch (tag->type) {
  case TAG_INTEGER:
    i = &tag->data.integer;
    if (compare_integer(i, &u64_max) > 0)
      return tag;
    if (compare_integer(i, &u32_max) > 0)
      return tag_init_u64(tag, integer_to_u64(i));
    if (compare_integer(i, &u16_max) > 0)
      return tag_init_u32(tag, integer_to_u32(i));
    if (compare_integer(i, &u8_max) > 0)
      return tag_init_u16(tag, integer_to_u16(i));
    if (compare_integer(i, &zero) >= 0)
      return tag_init_u8(tag, integer_to_u8(i));
    if (compare_integer(i, &s8_min) >= 0)
      return tag_init_s8(tag, integer_to_s8(i));
    if (compare_integer(i, &s16_min) >= 0)
      return tag_init_s16(tag, integer_to_s16(i));
    if (compare_integer(i, &s32_min) >= 0)
      return tag_init_s32(tag, integer_to_s32(i));
    if (compare_integer(i, &s64_min) >= 0)
      return tag_init_s64(tag, integer_to_s64(i));
    return tag;
  case TAG_S8:
    integer_init_s8(&j, tag->data.s8);
    integer_reduce(&j, tag);
    integer_clean(&j);
    return tag;
  case TAG_S16:
    integer_init_s16(&j, tag->data.s16);
    integer_reduce(&j, tag);
    integer_clean(&j);
    return tag;
  case TAG_S32:
    integer_init_s32(&j, tag->data.s32);
    integer_reduce(&j, tag);
    integer_clean(&j);
    return tag;
  case TAG_S64:
    integer_init_s64(&j, tag->data.s64);
    integer_reduce(&j, tag);
    integer_clean(&j);
    return tag;
  case TAG_U8:
    integer_init_u8(&j, tag->data.u8);
    integer_reduce(&j, tag);
    integer_clean(&j);
    return tag;
  case TAG_U16:
    integer_init_u16(&j, tag->data.u16);
    integer_reduce(&j, tag);
    integer_clean(&j);
    return tag;
  case TAG_U32:
    integer_init_u32(&j, tag->data.u32);
    integer_reduce(&j, tag);
    integer_clean(&j);
    return tag;
  case TAG_U64:
    integer_init_u64(&j, tag->data.u64);
    integer_reduce(&j, tag);
    integer_clean(&j);
    return tag;
  default:
    break;
  }
  return tag;
}

bool tag_is_alist (const s_tag *tag)
{
  assert(tag);
  if (! tag)
    return false;
  if (tag->type != TAG_LIST)
    return false;
  return list_is_alist((const s_list * const *) &tag->data.list);
}

bool tag_is_bound_var (const s_tag *tag)
{
  assert(tag);
  return (tag &&
          tag->type != TAG_VAR);
}

bool tag_is_cast (const s_tag *tag, const s_sym *type)
{
  assert(tag);
  return (tag &&
          type &&
          tag->type == TAG_CALL &&
          tag->data.call.ident.module == type &&
          tag->data.call.ident.sym == &g_sym_cast);
}

bool tag_is_number (const s_tag *tag)
{
  assert(tag);
  tag = tag_resolve_cow(tag);
  switch (tag->type) {
  case TAG_VOID:
  case TAG_ARRAY:
  case TAG_BLOCK:
  case TAG_BOOL:
  case TAG_CALL:
  case TAG_CFN:
  case TAG_CHARACTER:
  case TAG_FACT:
  case TAG_FN:
  case TAG_LIST:
  case TAG_MAP:
  case TAG_PTAG:
  case TAG_PTR:
  case TAG_PTR_FREE:
  case TAG_QUOTE:
  case TAG_STR:
  case TAG_STRUCT:
  case TAG_STRUCT_TYPE:
  case TAG_SYM:
  case TAG_TUPLE:
  case TAG_UNQUOTE:
  case TAG_VAR:
  case TAG_IDENT:
    return false;
  case TAG_COMPLEX:
  case TAG_F32:
  case TAG_F64:
  case TAG_F128:
  case TAG_INTEGER:
  case TAG_RATIO:
  case TAG_SW:
  case TAG_S64:
  case TAG_S32:
  case TAG_S16:
  case TAG_S8:
  case TAG_U8:
  case TAG_U16:
  case TAG_U32:
  case TAG_U64:
  case TAG_UW:
    return true;
  case TAG_COW:
    break;
  }
  err_puts("tag_is_number: invalid tag type");
  assert(! "tag_is_number: invalid tag type");
  abort();
  return false;
}

bool * tag_is_unbound_var (const s_tag *tag, bool *dest)
{
  assert(tag);
  if (! tag) {
    err_puts("tag_is_unbound_var: NULL tag");
    assert(! "tag_is_unbound_var: NULL tag");
    return NULL;
  }
  *dest = tag->type == TAG_VAR;
  return dest;
}

bool tag_is_zero(const s_tag *tag)
{
  assert(tag);
  switch (tag->type) {
    case TAG_INTEGER:
      return integer_is_zero(&tag->data.integer);
    case TAG_F32:
      return tag->data.f32 == 0.0f;
    case TAG_F64:
      return tag->data.f64 == 0.0;
    case TAG_S8:
      return tag->data.s8 == 0;
    case TAG_S16:
      return tag->data.s16 == 0;
    case TAG_S32:
      return tag->data.s32 == 0;
    case TAG_S64:
      return tag->data.s64 == 0;
    case TAG_U8:
      return tag->data.u8 == 0;
    case TAG_U16:
      return tag->data.u16 == 0;
    case TAG_U32:
      return tag->data.u32 == 0;
    case TAG_U64:
      return tag->data.u64 == 0;
    case TAG_UW:
      return tag->data.uw == 0;
    default:
      return false;
  }
}

/*
s_tag * tag_list (s_tag *tag, s_list *x)
{
  assert(tag);
  tag_clean(tag);
  return tag_init_list(tag, x);
}
*/

s_tag * tag_list_1 (s_tag *tag, const char *p)
{
  s_tag tmp = {0};
  assert(tag);
  tag_clean(tag);
  tmp.type = TAG_LIST;
  tmp.data.list = list_new_1(p);
  *tag = tmp;
  return tag;
}

bool * tag_lt (const s_tag *a, const s_tag *b, bool *dest)
{
  assert(a);
  assert(b);
  assert(dest);
  *dest = compare_tag(a, b) < 0 ? 1 : 0;
  return dest;
}

bool * tag_lte (const s_tag *a, const s_tag *b, bool *dest)
{
  assert(a);
  assert(b);
  assert(dest);
  *dest = compare_tag(a, b) <= 0 ? 1 : 0;
  return dest;
}

s_tag * tag_new (void)
{
  s_tag *dest;
  dest = alloc(sizeof(s_tag));
  if (! dest)
    return NULL;
  return dest;
}

s_tag * tag_new_1 (const char *p)
{
  s_tag *dest;
  dest = alloc(sizeof(s_tag));
  if (! dest)
    return NULL;
  if (! tag_init_1(dest, p)) {
    free(dest);
    return NULL;
  }
  return dest;
}

s_tag * tag_new_copy (const s_tag *src)
{
  s_tag *dest;
  dest = alloc(sizeof(s_tag));
  if (! dest)
    return NULL;
  if (! tag_init_copy(dest, src)) {
    free(dest);
    return NULL;
  }
  return dest;
}

bool * tag_not (const s_tag *tag, bool *dest)
{
  s_tag f;
  assert(tag);
  assert(dest);
  tag_init_bool(&f, false);
  *dest = compare_tag(tag, &f) == 0 ? true : false;
  return dest;
}

bool * tag_not_eq (const s_tag *a, const s_tag *b, bool *dest)
{
  assert(a);
  assert(b);
  assert(dest);
  *dest = compare_tag(a, b) != 0 ? 1 : 0;
  return dest;
}

bool * tag_or (const s_tag *a, const s_tag *b, bool *dest)
{
  s_tag f;
  assert(a);
  assert(b);
  assert(dest);
  tag_init_bool(&f, false);
  *dest = compare_tag(a, &f) != 0 ||
          compare_tag(b, &f) != 0 ? 1 : 0;
  return dest;
}

s_tag * tag_paren (const s_tag *tag, s_tag *dest)
{
  assert(tag);
  assert(dest);
  return tag_init_copy(dest, tag);
}

const s_tag * tag_resolve_cow (const s_tag *tag)
{
  while (tag->type == TAG_COW)
    tag = cow_read_only(tag->data.cow);
  if (! tag) {
    err_puts("tag_resolve_cow: cow was not frozen");
    assert(! "tag_resolve_cow: cow was not frozen");
    return NULL;
  }
  return tag;
}

uw * tag_size (const s_tag *tag, uw *dest)
{
  const s_sym *type;
  uw tmp = 0;
  assert(tag);
  if (tag->type == TAG_VAR) {
    if (! sym_type_size(&tag->data.var.type, &tmp))
      return NULL;
  }
  else if (! tag_type(tag, &type) ||
           ! sym_type_size(&type, &tmp))
    return NULL;
  *dest = tmp;
  return dest;
}

bool tag_to_const_pointer (const s_tag *tag, const s_sym *type,
                           const void **dest)
{
  e_tag_type tag_type;
  if (! sym_to_tag_type(type, &tag_type))
    return false;
  if (type != &g_sym_Tag &&
      tag->type != tag_type) {
    err_write_1("tag_to_const_pointer: cannot cast ");
    err_write_1(tag_type_to_string(tag->type));
    err_write_1(" to ");
    err_puts(type->str.ptr.pchar);
    assert(! "tag_to_const_pointer: cannot cast");
    return false;
  }
  switch (tag_type) {
  case TAG_ARRAY:       *dest = &tag->data.array;       return true;
  case TAG_BLOCK:       *dest = &tag->data.block;       return true;
  case TAG_BOOL:        *dest = &tag->data.bool;        return true;
  case TAG_CALL:        *dest = &tag->data.call;        return true;
  case TAG_CFN:         *dest = &tag->data.cfn;         return true;
  case TAG_CHARACTER:   *dest = &tag->data.character;   return true;
  case TAG_COMPLEX:     *dest = &tag->data.complex;     return true;
  case TAG_COW:         *dest = &tag->data.cow;         return true;
  case TAG_F32:         *dest = &tag->data.f32;         return true;
  case TAG_F64:         *dest = &tag->data.f64;         return true;
  case TAG_F128:        *dest = &tag->data.f128;        return true;
  case TAG_FACT:        *dest = &tag->data.fact;        return true;
  case TAG_FN:          *dest = &tag->data.fn;          return true;
  case TAG_IDENT:       *dest = &tag->data.ident;       return true;
  case TAG_INTEGER:     *dest = &tag->data.integer;     return true;
  case TAG_SW:          *dest = &tag->data.sw;          return true;
  case TAG_S64:         *dest = &tag->data.s64;         return true;
  case TAG_S32:         *dest = &tag->data.s32;         return true;
  case TAG_S16:         *dest = &tag->data.s16;         return true;
  case TAG_S8:          *dest = &tag->data.s8;          return true;
  case TAG_U8:          *dest = &tag->data.u8;          return true;
  case TAG_U16:         *dest = &tag->data.u16;         return true;
  case TAG_U32:         *dest = &tag->data.u32;         return true;
  case TAG_U64:         *dest = &tag->data.u64;         return true;
  case TAG_UW:          *dest = &tag->data.uw;          return true;
  case TAG_LIST:        *dest = &tag->data.list;        return true;
  case TAG_MAP:         *dest = &tag->data.map;         return true;
  case TAG_PTAG:        *dest = &tag->data.ptag;        return true;
  case TAG_PTR:         *dest = &tag->data.ptr.p;       return true;
  case TAG_PTR_FREE:    *dest = &tag->data.ptr_free.p;  return true;
  case TAG_QUOTE:       *dest = &tag->data.quote;       return true;
  case TAG_RATIO:       *dest = &tag->data.ratio;       return true;
  case TAG_STR:         *dest = &tag->data.str;         return true;
  case TAG_STRUCT:
    if (type == &g_sym_Struct) {
      *dest = &tag->data.struct_;
      return true;
    }
    if (type == tag->data.struct_.type->module) {
      *dest = tag->data.struct_.data;
      assert(*dest);
      return true;
    }
    err_write_1("tag_to_const_pointer: cannot cast ");
    err_write_1(tag_type_to_string(tag->type));
    err_write_1(" to ");
    err_inspect_sym(&type);
    err_write_1("\n");
    assert(! "tag_to_const_pointer: cannot cast");
    return false;
  case TAG_STRUCT_TYPE: *dest = &tag->data.struct_type; return true;
  case TAG_SYM:         *dest = &tag->data.sym;         return true;
  case TAG_TUPLE:       *dest = &tag->data.tuple;       return true;
  case TAG_UNQUOTE:     *dest = &tag->data.unquote;     return true;
  case TAG_VAR:         *dest = tag;                    return true;
  case TAG_VOID:        *dest = NULL;                   return true;
  }
  err_write_1("tag_to_const_pointer: invalid tag type: ");
  err_puts(tag_type_to_string(tag_type));
  assert(! "tag_to_const_pointer: invalid tag type");
  return false;
}

bool tag_to_ffi_pointer (s_tag *tag, const s_sym *type, void **dest)
{
  if (type == &g_sym_Tag) {
    *dest = tag;
    return true;
  }
  switch (tag->type) {
  case TAG_ARRAY:
    if (type == &g_sym_Array) {
      *dest = tag->data.array.data;
      return true;
    }
    goto invalid_cast;
  case TAG_BLOCK:
    if (type == &g_sym_Block) {
      *dest = &tag->data.block;
      return true;
    }
    goto invalid_cast;
  case TAG_BOOL:
    if (type == &g_sym_Bool) {
      *dest = &tag->data.bool;
      return true;
    }
    goto invalid_cast;
  case TAG_CALL:
    if (type == &g_sym_Call) {
      *dest = &tag->data.call;
      return true;
    }
    goto invalid_cast;
  case TAG_CFN:
    if (type == &g_sym_Cfn) {
      *dest = &tag->data.cfn;
      return true;
    }
    goto invalid_cast;
  case TAG_CHARACTER:
    if (type == &g_sym_Character) {
      *dest = &tag->data.character;
      return true;
    }
    goto invalid_cast;
  case TAG_COMPLEX:
    if (type == &g_sym_Complex) {
      *dest = &tag->data.complex;
      return true;
    }
    goto invalid_cast;
  case TAG_COW:
    if (type == &g_sym_Cow) {
      *dest = &tag->data.cow;
      return true;
    }
    // FIXME: other types
    goto invalid_cast;
  case TAG_F32:
    if (type == &g_sym_F32) {
      *dest = &tag->data.f32;
      return true;
    }
    goto invalid_cast;
  case TAG_F64:
    if (type == &g_sym_F64) {
      *dest = &tag->data.f64;
      return true;
    }
    goto invalid_cast;
  case TAG_F128:
    if (type == &g_sym_F128) {
      *dest = &tag->data.f128;
      return true;
    }
    goto invalid_cast;
  case TAG_FACT:
    if (type == &g_sym_Fact) {
      *dest = &tag->data.fact;
      return true;
    }
    goto invalid_cast;
  case TAG_FN:
    if (type == &g_sym_Fn) {
      *dest = &tag->data.fn;
      return true;
    }
    goto invalid_cast;
  case TAG_IDENT:
    if (type == &g_sym_Ident) {
      *dest = &tag->data.ident;
      return true;
    }
    goto invalid_cast;
  case TAG_INTEGER:
    if (type == &g_sym_Integer) {
      *dest = &tag->data.integer;
      return true;
    }
    goto invalid_cast;
  case TAG_LIST:
    if (type == &g_sym_List) {
      *dest = &tag->data.list;
      return true;
    }
    goto invalid_cast;
  case TAG_MAP:
    if (type == &g_sym_Map) {
      *dest = &tag->data.map;
      return true;
    }
    goto invalid_cast;
  case TAG_PTAG:
    if (type == &g_sym_Ptag) {
      *dest = (void *) tag->data.ptag;
      return true;
    }
    goto invalid_cast;
  case TAG_PTR:
    if (type == &g_sym_Ptr) {
      *dest = &tag->data.ptr.p;
      return true;
    }
    *dest = tag->data.ptr.p;
    return true;
  case TAG_PTR_FREE:
    if (type == &g_sym_Ptr ||
        type == &g_sym_PtrFree) {
      *dest = &tag->data.ptr_free.p;
      return true;
    }
    *dest = tag->data.ptr.p;
    return true;
  case TAG_QUOTE:
    if (type == &g_sym_Quote) {
      *dest = &tag->data.quote;
      return true;
    }
    goto invalid_cast;
  case TAG_RATIO:
    if (type == &g_sym_Ratio) {
      *dest = &tag->data.ratio;
      return true;
    }
    goto invalid_cast;
  case TAG_STR:
    if (type == &g_sym_Str) {
      *dest = &tag->data.str;
      return true;
    }
    if (type == &g_sym_Char__star) {
      *dest = (void *) tag->data.str.ptr.pchar;
      return true;
    }
    goto invalid_cast;
  case TAG_STRUCT:
    if (type == &g_sym_Struct) {
      *dest = &tag->data.struct_;
      return true;
    }
    if (type == tag->data.struct_.type->module) {
      *dest = tag->data.struct_.data;
      assert(*dest);
      return true;
    }
    goto invalid_cast;
  case TAG_STRUCT_TYPE:
    if (type == &g_sym_StructType) {
      *dest = &tag->data.struct_type;
      return true;
    }
    goto invalid_cast;
  case TAG_SW:
    if (type == &g_sym_Sw) {
      *dest = &tag->data.sw;
      return true;
    }
    goto invalid_cast;
  case TAG_SYM:
    if (type == &g_sym_Sym) {
      *dest = (void *) &tag->data.sym;
      return true;
    }
    if (type == &g_sym_Str) {
      *dest = (void *) &tag->data.sym->str;
      return true;
    }
    if (type == &g_sym_Char__star) {
      *dest = (void *) tag->data.sym->str.ptr.pchar;
      return true;
    }
    goto invalid_cast;
  case TAG_S8:
    if (type == &g_sym_S8) {
      *dest = &tag->data.s8;
      return true;
    }
    goto invalid_cast;
  case TAG_S16:
    if (type == &g_sym_S16) {
      *dest = &tag->data.s16;
      return true;
    }
    goto invalid_cast;
  case TAG_S32:
    if (type == &g_sym_S32) {
      *dest = &tag->data.s32;
      return true;
    }
    goto invalid_cast;
  case TAG_S64:
    if (type == &g_sym_S64) {
      *dest = &tag->data.s64;
      return true;
    }
    goto invalid_cast;
  case TAG_TUPLE:
    if (type == &g_sym_Tuple) {
      *dest = &tag->data.tuple;
      return true;
    }
    goto invalid_cast;
  case TAG_U8:
    if (type == &g_sym_U8) {
      *dest = &tag->data.u8;
      return true;
    }
    goto invalid_cast;
  case TAG_U16:
    if (type == &g_sym_U16) {
      *dest = &tag->data.u16;
      return true;
    }
    goto invalid_cast;
  case TAG_U32:
    if (type == &g_sym_U32) {
      *dest = &tag->data.u32;
      return true;
    }
    goto invalid_cast;
  case TAG_U64:
    if (type == &g_sym_U64) {
      *dest = &tag->data.u64;
      return true;
    }
    goto invalid_cast;
  case TAG_UNQUOTE:
    if (type == &g_sym_Unquote) {
      *dest = &tag->data.unquote;
      return true;
    }
    goto invalid_cast;
  case TAG_UW:
    if (type == &g_sym_Uw) {
      *dest = &tag->data.uw;
      return true;
    }
    goto invalid_cast;
  case TAG_VAR:
    if (type == &g_sym_Tag) {
      *dest = tag;
      return true;
    }
    goto invalid_cast;
  case TAG_VOID:
    if (type == &g_sym_Void) {
      *dest = NULL;
      return true;
    }
    goto invalid_cast;
  }
  err_puts("tag_to_ffi_pointer: invalid tag type");
  assert(! "tag_to_ffi_pointer: invalid tag type");
  return false;
 invalid_cast:
  err_write_1("tag_to_ffi_pointer: cannot cast ");
  err_write_1(tag_type_to_string(tag->type));
  err_write_1(" to ");
  err_puts(type->str.ptr.pchar);
  assert(! "tag_to_ffi_pointer: cannot cast");
  return false;
}

bool tag_to_pointer (s_tag *tag, const s_sym *type, void **dest)
{
  e_tag_type tag_type;
  if (! sym_to_tag_type(type, &tag_type))
    return false;
  if (tag->type != tag_type) {
    err_write_1("tag_to_pointer: cannot cast ");
    err_write_1(tag_type_to_string(tag->type));
    err_write_1(" to ");
    err_puts(type->str.ptr.pchar);
    assert(! "tag_to_pointer: cannot cast");
    return false;
  }
  switch (tag_type) {
  case TAG_VOID:        *dest = NULL;                   return true;
  case TAG_ARRAY:       *dest = &tag->data.array;       return true;
  case TAG_BLOCK:       *dest = &tag->data.block;       return true;
  case TAG_BOOL:        *dest = &tag->data.bool;        return true;
  case TAG_CALL:        *dest = &tag->data.call;        return true;
  case TAG_CFN:         *dest = &tag->data.cfn;         return true;
  case TAG_CHARACTER:   *dest = &tag->data.character;   return true;
  case TAG_COMPLEX:     *dest = &tag->data.complex;     return true;
  case TAG_COW:         *dest = &tag->data.cow;         return true;
  case TAG_F32:         *dest = &tag->data.f32;         return true;
  case TAG_F64:         *dest = &tag->data.f64;         return true;
  case TAG_F128:        *dest = &tag->data.f128;        return true;
  case TAG_FACT:        *dest = &tag->data.fact;        return true;
  case TAG_FN:          *dest = &tag->data.fn;          return true;
  case TAG_IDENT:       *dest = &tag->data.ident;       return true;
  case TAG_INTEGER:     *dest = &tag->data.integer;     return true;
  case TAG_SW:          *dest = &tag->data.sw;          return true;
  case TAG_S64:         *dest = &tag->data.s64;         return true;
  case TAG_S32:         *dest = &tag->data.s32;         return true;
  case TAG_S16:         *dest = &tag->data.s16;         return true;
  case TAG_S8:          *dest = &tag->data.s8;          return true;
  case TAG_U8:          *dest = &tag->data.u8;          return true;
  case TAG_U16:         *dest = &tag->data.u16;         return true;
  case TAG_U32:         *dest = &tag->data.u32;         return true;
  case TAG_U64:         *dest = &tag->data.u64;         return true;
  case TAG_UW:          *dest = &tag->data.uw;          return true;
  case TAG_LIST:        *dest = &tag->data.list;        return true;
  case TAG_MAP:         *dest = &tag->data.map;         return true;
  case TAG_PTAG:        *dest = &tag->data.ptag;        return true;
  case TAG_PTR:         *dest = &tag->data.ptr.p;       return true;
  case TAG_PTR_FREE:    *dest = &tag->data.ptr_free.p;  return true;
  case TAG_QUOTE:       *dest = &tag->data.quote;       return true;
  case TAG_STR:         *dest = &tag->data.str;         return true;
  case TAG_STRUCT:
    if (type == &g_sym_Struct) {
      *dest = &tag->data.struct_;
      return true;
    }
    if (type == tag->data.struct_.type->module) {
      *dest = tag->data.struct_.data;
      return true;
    }
    goto invalid_cast;
  case TAG_STRUCT_TYPE: *dest = &tag->data.struct_type; return true;
  case TAG_SYM:         *dest = &tag->data.sym;         return true;
  case TAG_TUPLE:       *dest = &tag->data.tuple;       return true;
  case TAG_UNQUOTE:     *dest = &tag->data.unquote;     return true;
  case TAG_VAR:         *dest = tag;                    return true;
  case TAG_RATIO:       *dest = &tag->data.ratio;       return true;
  }
  err_puts("tag_to_pointer: invalid tag type");
  assert(! "tag_to_pointer: invalid tag type");
  return false;
 invalid_cast:
  err_write_1("tag_to_pointer: invalid cast from ");
  if (tag->type == TAG_STRUCT)
    err_inspect_sym(&tag->data.struct_.type->module);
  else
    err_write_1(tag_type_to_string(tag->type));
  err_write_1(" to ");
  err_inspect_sym(&type);
  err_write_1("\n");
  assert(! "tag_to_pointer: invalid cast");
  return false;
}

const s_sym ** tag_type (const s_tag *tag, const s_sym **dest)
{
  assert(tag);
  assert(dest);
  switch (tag->type) {
  case TAG_VOID:        *dest = &g_sym_Void;       return dest;
  case TAG_ARRAY:
    *dest = tag->data.array.array_type;
    return dest;
  case TAG_BLOCK:       *dest = &g_sym_Block;      return dest;
  case TAG_BOOL:        *dest = &g_sym_Bool;       return dest;
  case TAG_CALL:        *dest = &g_sym_Call;       return dest;
  case TAG_CFN:         *dest = &g_sym_Cfn;        return dest;
  case TAG_CHARACTER:   *dest = &g_sym_Character;  return dest;
  case TAG_COMPLEX:     *dest = &g_sym_Complex;    return dest;
  case TAG_COW:         *dest = &g_sym_Cow;        return dest;
  case TAG_F32:         *dest = &g_sym_F32;        return dest;
  case TAG_F64:         *dest = &g_sym_F64;        return dest;
  case TAG_F128:        *dest = &g_sym_F128;       return dest;
  case TAG_FACT:        *dest = &g_sym_Fact;       return dest;
  case TAG_FN:          *dest = &g_sym_Fn;         return dest;
  case TAG_IDENT:       *dest = &g_sym_Ident;      return dest;
  case TAG_INTEGER:     *dest = &g_sym_Integer;    return dest;
  case TAG_SW:          *dest = &g_sym_Sw;         return dest;
  case TAG_S64:         *dest = &g_sym_S64;        return dest;
  case TAG_S32:         *dest = &g_sym_S32;        return dest;
  case TAG_S16:         *dest = &g_sym_S16;        return dest;
  case TAG_S8:          *dest = &g_sym_S8;         return dest;
  case TAG_U8:          *dest = &g_sym_U8;         return dest;
  case TAG_U16:         *dest = &g_sym_U16;        return dest;
  case TAG_U32:         *dest = &g_sym_U32;        return dest;
  case TAG_U64:         *dest = &g_sym_U64;        return dest;
  case TAG_UW:          *dest = &g_sym_Uw;         return dest;
  case TAG_LIST:        *dest = &g_sym_List;       return dest;
  case TAG_MAP:         *dest = &g_sym_Map;        return dest;
  case TAG_PTAG:        *dest = &g_sym_Ptag;       return dest;
  case TAG_PTR:         *dest = &g_sym_Ptr;        return dest;
  case TAG_PTR_FREE:    *dest = &g_sym_PtrFree;    return dest;
  case TAG_QUOTE:       *dest = &g_sym_Quote;      return dest;
  case TAG_RATIO:       *dest = &g_sym_Ratio;      return dest;
  case TAG_STR:         *dest = &g_sym_Str;        return dest;
  case TAG_STRUCT:      *dest = tag->data.struct_.type->module;
                                                   return dest;
  case TAG_STRUCT_TYPE: *dest = &g_sym_StructType; return dest;
  case TAG_SYM:         *dest = &g_sym_Sym;        return dest;
  case TAG_TUPLE:       *dest = &g_sym_Tuple;      return dest;
  case TAG_UNQUOTE:     *dest = &g_sym_Unquote;    return dest;
  case TAG_VAR:         *dest = &g_sym_Var;        return dest;
  }
  err_puts("tag_type: invalid tag type");
  assert(! "tag_type: invalid tag type");
  return NULL;
}

bool tag_xor (const s_tag *a, const s_tag *b)
{
  s_tag f;
  tag_init_bool(&f, false);
  return (compare_tag(a, &f) != 0) != (compare_tag(b, &f) != 0);
}
kc3-lang/kc3/libkc3/tag.c

Commit

libkc3/tag.c
