ecl/src/c/printer/write_symbol.d

/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */

/*
 * write_symbol.d - print a symbol
 *
 * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
 * Copyright (c) 1990 Giuseppe Attardi
 * Copyright (c) 2001 Juan Jose Garcia Ripoll
 *
 * See file 'LICENSE' for the copyright details.
 *
 */

#include <ecl/ecl.h>
#include <ecl/internal.h>

static bool
potential_number_p(cl_object s, int base)
{
  /* See ANSI 2.3.1.1 */
  static cl_index i, l;
  ecl_character c;
  /* A potential number must contain at least one digit */
  bool some_digit = FALSE;

  l = s->base_string.fillp;
  if (l == 0)
    return FALSE;
  c = ecl_char(s, 0);

  /* A potential number must begin with a digit, sign or
     extension character (^ _) */
  if (ecl_digitp(c,base) >= 0)
    some_digit = TRUE;
  else if (c != '+' && c != '-' && c != '^' && c != '_')
    return FALSE;

  /* A potential number cannot end with a sign */
  c = ecl_char(s, l-1);
  if (c == '+' || c == '-')
    return FALSE;

  for (i = 1;  i < l;  i++) {
    c = ecl_char(s, i);
    /* It can only contain digits, signs, ratio markers,
     * extension characters and number markers. Number
     * markers are letters, but two adjacent letters fail
     * to be a number marker. */
    if (ecl_digitp(c, base) >= 0) {
      some_digit = TRUE;
    } else if (c == '+' || c == '-' ||
               c == '/' || c == '.' || c == '^' || c == '_') {
      continue;
    } else if (ecl_alpha_char_p(c) &&
               (((i+1) >= l) || !ecl_alpha_char_p(ecl_char(s, i+1)))) {
      continue;
    } else {
      return FALSE;
    }
  }
  return some_digit;
}

#define needs_to_be_inverted(s) (ecl_string_case(s) != 0)

static bool
all_dots(cl_object s)
{
  cl_index i;
  for (i = 0;  i < s->base_string.fillp;  i++)
    if (ecl_char(s, i) != '.')
      return 0;
  return 1;
}

static bool
needs_to_be_escaped(cl_object s, cl_object readtable, cl_object print_case)
{
  int action = readtable->readtable.read_case;
  cl_index i;
  if (potential_number_p(s, ecl_print_base()))
    return 1;
  /* The value of *PRINT-ESCAPE* is T. We need to check whether the
   * symbol name S needs to be escaped. This will happen if it has some
   * strange character, or if it has a lowercase character (because such
   * a character cannot be read with the standard readtable) or if the
   * string has to be escaped according to readtable case and the rules
   * of 22.1.3.3.2. */
  for (i = 0; i < s->base_string.fillp;  i++) {
    int c = ecl_char(s, i);
    int syntax = ecl_readtable_get(readtable, c, 0);
    if (syntax != cat_constituent ||
        ecl_invalid_character_p(c) ||
        (c) == ':')
      return 1;
    if ((action == ecl_case_downcase) && ecl_upper_case_p(c))
      return 1;
    if (ecl_lower_case_p(c))
      return 1;
  }
  return 0;
}

static void
write_symbol_string(cl_object s, int action, cl_object print_case,
                    cl_object stream, bool escape)
{
  cl_index i;
  bool capitalize;
  if (action == ecl_case_invert) {
    if (!needs_to_be_inverted(s))
      action = ecl_case_preserve;
  }
  if (escape)
    ecl_write_char('|', stream);
  capitalize = 1;
  for (i = 0;  i < s->base_string.fillp;  i++) {
    int c = ecl_char(s, i);
    if (escape) {
      if (c == '|' || c == '\\') {
        ecl_write_char('\\', stream);
      }
    } else if (action != ecl_case_preserve) {
      if (ecl_upper_case_p(c)) {
        if ((action == ecl_case_invert) ||
            ((action == ecl_case_upcase) &&
             ((print_case == @':downcase') ||
              ((print_case == @':capitalize') && !capitalize))))
          {
            c = ecl_char_downcase(c);
          }
        capitalize = 0;
      } else if (ecl_lower_case_p(c)) {
        if ((action == ecl_case_invert) ||
            ((action == ecl_case_downcase) &&
             ((print_case == @':upcase') ||
              ((print_case == @':capitalize') && capitalize))))
          {
            c = ecl_char_upcase(c);
          }
        capitalize = 0;
      } else {
        capitalize = !ecl_alphanumericp(c);
      }
    }
    ecl_write_char(c, stream);
  }
  if (escape)
    ecl_write_char('|', stream);
}

static bool
forced_print_package(cl_object package)
{
  cl_object print_package = ecl_symbol_value(@'si::*print-package*');
  return !Null(print_package) && (print_package != package);
}

void
_ecl_write_symbol(cl_object x, cl_object stream)
{
  cl_object readtable = ecl_current_readtable();
  cl_object print_case = ecl_print_case();
  cl_object package;
  cl_object name;
  int intern_flag;
  bool print_readably = ecl_print_readably();
  bool forced_package = 0;

  if (Null(x)) {
    package = ECL_NIL_SYMBOL->symbol.hpack;
    name = ECL_NIL_SYMBOL->symbol.name;
  } else {
    package = x->symbol.hpack;
    name = x->symbol.name;
  }

  if (!print_readably && !ecl_print_escape()) {
    write_symbol_string(name, readtable->readtable.read_case,
                        print_case, stream, 0);
    return;
  }
  /* From here on, print-escape is true which means that it should
   * be possible to recover the same symbol by reading it with
   * the standard readtable (which has readtable-case = :UPCASE)
   */
  if (Null(package)) {
    if (print_readably || ecl_print_gensym())
      writestr_stream("#:", stream);
  } else if (package == cl_core.keyword_package) {
    ecl_write_char(':', stream);
  } else if ((forced_package = forced_print_package(package))
             || ecl_find_symbol(name, ecl_current_package(), &intern_flag) != x
             || (intern_flag == 0))
    {
      cl_object name = package->pack.name;
      write_symbol_string(name, readtable->readtable.read_case,
                          print_case, stream,
                          needs_to_be_escaped(name, readtable, print_case));
      if (ecl_find_symbol(ecl_symbol_name(x), package, &intern_flag) != x)
        ecl_internal_error("can't print symbol");
      if (intern_flag == ECL_INTERNAL || forced_package) {
        writestr_stream("::", stream);
      } else if (intern_flag == ECL_EXTERNAL) {
        ecl_write_char(':', stream);
      } else {
        FEerror("Pathological symbol --- cannot print.", 0);
      }
    }
  write_symbol_string(name, readtable->readtable.read_case, print_case, stream,
                      needs_to_be_escaped(name, readtable, print_case) ||
                      all_dots(name));
}