ecl/src/c/assignment.d

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

/*
 * assignment.c - assignment
 *
 * 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 <string.h>
#include <ecl/ecl.h>
#include <ecl/internal.h>

static void FEconstant_assignment(cl_object var) ecl_attr_noreturn;

static void
FEconstant_assignment(cl_object var)
{
  FEinvalid_variable("Cannot assign to the constant ~S.", var);
}

cl_object
cl_set(cl_object var, cl_object value)
{
  const cl_env_ptr env = ecl_process_env();
  unlikely_if (Null(var)) {
    FEconstant_assignment(var);
  }
  unlikely_if (ecl_t_of(var) != t_symbol) {
    FEwrong_type_nth_arg(@[set], 1, var, @[symbol]);
  }
  ecl_return1(env, ecl_cmp_setq(env, var, value));
}

cl_object
ecl_setq(cl_env_ptr env, cl_object var, cl_object value)
{
  unlikely_if (Null(var)) {
    FEconstant_assignment(var);
  }
  unlikely_if (ecl_t_of(var) != t_symbol) {
    FEwrong_type_nth_arg(@[setq], 1, var, @[symbol]);
  }
  return ecl_cmp_setq(env, var, value);
}

/* ecl_cmp_setq does the minimal amount of checking necessary to
 * implement SETQ for objects that have been checked to be non-null
 * symbols by the compiler. */
cl_object
ecl_cmp_setq(cl_env_ptr env, cl_object var, cl_object value)
{
  unlikely_if (var->symbol.stype & ecl_stp_constant) {
    FEconstant_assignment(var);
  }
  return ECL_SETQ(env, var, value);
}

#ifdef ECL_THREADS
cl_object
mp_compare_and_swap_symbol_value(cl_object var, cl_object old, cl_object new)
{
  unlikely_if (Null(var)) {
    FEconstant_assignment(var);
  }
  unlikely_if (ecl_t_of(var) != t_symbol) {
    FEwrong_type_nth_arg(@[mp::compare-and-swap-symbol-value], 1, var, @[symbol]);
  }
  unlikely_if (var->symbol.stype & ecl_stp_constant) {
    FEconstant_assignment(var);
  }
  return ecl_compare_and_swap(ecl_bds_ref(ecl_process_env(), var), old, new);
}

cl_object
mp_atomic_incf_symbol_value(cl_object var, cl_object increment)
{
  unlikely_if (Null(var)) {
    FEconstant_assignment(var);
  }
  unlikely_if (ecl_t_of(var) != t_symbol) {
    FEwrong_type_nth_arg(@[mp::atomic-incf-symbol-value], 1, var, @[symbol]);
  }
  unlikely_if (var->symbol.stype & ecl_stp_constant) {
    FEconstant_assignment(var);
  }
  return ecl_atomic_incf(ecl_bds_ref(ecl_process_env(), var), increment);
}
#endif /* ECL_THREADS */

static cl_object
unbound_setf_function_error(cl_narg narg, ...)
{
  const cl_env_ptr the_env = ecl_process_env();
  cl_object name = the_env->function->cclosure.env;
  FEundefined_function(cl_list(2, @'setf', name));
}

static cl_object
make_setf_function_error(cl_object name)
{
  return ecl_make_cclosure_va((cl_objectfn)unbound_setf_function_error,
                              name, ECL_NIL, 0);
}

cl_object
ecl_setf_definition(cl_object sym, cl_object createp)
{
  cl_object pair = sym->symbol.sfdef;
  if (Null(pair) && !Null(createp)) {
    createp = make_setf_function_error(sym);
    pair = ecl_cons(createp, ECL_NIL);
    sym->symbol.sfdef = pair;
  }
  return pair;
}

cl_object
si_setf_definition(cl_object sym, cl_object value)
{
  @(return ecl_setf_definition(sym, value));
}

static void
ecl_rem_setf_definition(cl_object sym)
{
  cl_object pair = sym->symbol.sfdef;
  if (!Null(pair)) {
    ECL_RPLACA(pair, make_setf_function_error(sym));
    ECL_RPLACD(pair, ECL_NIL);
  }
}

@(defun si::fset (fname def &optional macro pprint)
  cl_object sym = si_function_block_name(fname);
  cl_object pack;
  bool mflag;
  int type;
@
  if (Null(cl_functionp(def)))
    FEinvalid_function(def);
  pack = ecl_symbol_package(sym);
  if (pack != ECL_NIL
      && pack->pack.locked
      && ECL_SYM_VAL(ecl_process_env(),
                     @'si::*ignore-package-locks*') == ECL_NIL) {
    CEpackage_error("Attempt to redefine function ~S in locked package.",
                    "Ignore lock and proceed", pack, 1, fname);
  }
  mflag = !Null(macro);
  type = ecl_symbol_type(sym);
  if ((type & ecl_stp_special_form) && !mflag) {
    FEerror("Given that ~S is a special form, ~S cannot be defined as a function.",
            2, sym, fname);
  }
  if (ECL_SYMBOLP(fname)) {
    if (mflag) {
      type |= ecl_stp_macro;
      sym->symbol.macfun = def;
      ECL_FMAKUNBOUND(sym);
    } else {
      type &= ~ecl_stp_macro;
      ECL_SYM_FUN(sym) = def;
    }
    ecl_symbol_type_set(sym, type);
    ecl_clear_compiler_properties(sym);
#ifndef ECL_CMU_FORMAT
    if (pprint == ECL_NIL)
      si_rem_sysprop(sym, @'si::pretty-print-format');
    else
      si_put_sysprop(sym, @'si::pretty-print-format', pprint);
#endif
  } else if (mflag) {
    FEerror("~S is not a valid name for a macro.", 1, fname);
  } else {
    cl_object pair = ecl_setf_definition(sym, def);
    ECL_RPLACA(pair, def);
    ECL_RPLACD(pair, sym);
  }
  @(return def);
@)

cl_object
cl_makunbound(cl_object sym)
{
  if (ecl_symbol_type(sym) & ecl_stp_constant)
    FEinvalid_variable("Cannot unbind the constant ~S.", sym);
  ECL_SETQ(ecl_process_env(), sym, OBJNULL);
  @(return sym);
}

cl_object
cl_fmakunbound(cl_object fname)
{
  cl_object sym = si_function_block_name(fname);
  cl_object pack = ecl_symbol_package(sym);
  if (pack != ECL_NIL
      && pack->pack.locked
      && ECL_SYM_VAL(ecl_process_env(),
                     @'si::*ignore-package-locks*') == ECL_NIL) {
    CEpackage_error("Attempt to redefine function ~S in locked package.",
                    "Ignore lock and proceed", pack, 1, fname);
  }
  if (ECL_SYMBOLP(fname)) {
    ecl_clear_compiler_properties(sym);
    ECL_FMAKUNBOUND(sym);
    sym->symbol.macfun = ECL_NIL;
    ecl_symbol_type_set(sym, ecl_symbol_type(sym) & ~ecl_stp_macro);
  } else {
    ecl_rem_setf_definition(sym);
    si_rem_sysprop(sym, @'si::setf-method');
  }
  @(return fname);
}

void
ecl_clear_compiler_properties(cl_object sym)
{
  if (ecl_option_values[ECL_OPT_BOOTED]) {
    funcall(2, @'si::clear-compiler-properties', sym);
  }
}

cl_object
si_get_sysprop(cl_object sym, cl_object prop)
{
  cl_env_ptr the_env = ecl_process_env();
  ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) {
    cl_object plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL);
    prop = ecl_getf(plist, prop, OBJNULL);
  } ECL_WITH_GLOBAL_ENV_RDLOCK_END;
  if (prop == OBJNULL) {
    @(return ECL_NIL ECL_NIL);
  } else {
    @(return prop ECL_T);
  }
}

cl_object
si_put_sysprop(cl_object sym, cl_object prop, cl_object value)
{
  cl_env_ptr the_env = ecl_process_env();
  ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) {
    cl_object plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL);
    ecl_sethash(sym, cl_core.system_properties, si_put_f(plist, value, prop));
  } ECL_WITH_GLOBAL_ENV_WRLOCK_END;
  @(return value);
}

cl_object
si_rem_sysprop(cl_object sym, cl_object prop)
{
  const cl_env_ptr the_env = ecl_process_env();
  cl_object plist, found;
  ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) {
    plist = ecl_gethash_safe(sym, cl_core.system_properties, ECL_NIL);
    plist = si_rem_f(plist, prop);
    found = ecl_nth_value(the_env, 1);
    ecl_sethash(sym, cl_core.system_properties, plist);
  } ECL_WITH_GLOBAL_ENV_WRLOCK_END;
  ecl_return1(the_env, found);
}

cl_object
si_copy_sysprop(cl_object sym_old, cl_object sym_new)
{
  cl_env_ptr the_env = ecl_process_env();
  cl_object plist = ECL_NIL;
  ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) {
    plist = ecl_gethash_safe(sym_old, cl_core.system_properties, ECL_NIL);
    if (!Null(plist)) {
      ecl_sethash(sym_new, cl_core.system_properties, plist);
    }
  } ECL_WITH_GLOBAL_ENV_WRLOCK_END;
  @(return plist);
}