/*
 * CLISP Symbol functions
 * Bruno Haible 1990-2005
 * Sam Steingold 2001-2009
 * German comments and names translated into English: Reini Urban 2007-11
 */

#include "lispbibl.c"

/* Error when the symbol's property list has odd length.
 error_sym_plist_odd(symbol);
 > symbol: Symbol */
local _Noreturn void error_sym_plist_odd (object symbol) {
  pushSTACK(Symbol_plist(symbol)); /* TYPE-ERROR slot DATUM */
  pushSTACK(S(plist));          /* TYPE-ERROR slot EXPECTED-TYPE*/
  pushSTACK(symbol); pushSTACK(S(get));
  error(type_error,GETTEXT("~S: the property list of ~S has an odd length"));
}

/* UP: find the key in the property list
 > plist_: the address of the plist
 > key: indicator
 < tail: eq(Car(*tail),key), or a pointer to an atom if not found,
         or NULL if odd length */
local inline gcv_object_t* plist_find (gcv_object_t *plist_, object key) {
  while (1) {
    var object plistr = *plist_;
    if (atomp(plistr)) /* not found */
      return plist_;
    if (eq(Car(plistr),key)) /* found */
      return plist_;
    plistr = Cdr(plistr);
    if (atomp(plistr)) /* odd length --> error */
      return NULL;
    plist_ = &Cdr(plistr);
  }
}

/* UP: find a property in the property list of the symbol.
 get(symbol,key)
 > symbol: a Symbol
 > key: indicator
 < value: the value of key in the property list or unbound. */
modexp object get (object symbol, object key) {
  var gcv_object_t* plistr_ = plist_find(&(Symbol_plist(symbol)),key);
  if (plistr_ == NULL) /* property list has odd length */
    error_sym_plist_odd(symbol);
  var object plistr = *plistr_;
  if (endp(plistr)) /* not found */
    return unbound;
  /* key found */
  plistr = Cdr(plistr);
  if (atomp(plistr))
    error_sym_plist_odd(symbol);
  return Car(plistr);
}

LISPFUNN(putd,2)
{/* (SYS::%PUTD symbol function) */
  var object symbol = check_symbol(STACK_1);
  var object fun = STACK_0;
  /* fun must be a SUBR, FSUBR, Closure or #<MACRO expander>,
     not a lambda-expression. */
  if (functionp(fun) || fsubrp(fun))
    goto ok;
  else if (macrop(fun)) /* #<MACRO expander> is ok */
    goto ok;
  else if (consp(fun) && eq(Car(fun),S(lambda))) { /* Lambda-Expression? */
    error_lambda_expression(S(putd),fun);
  }
  fun = check_function(fun);
 ok: /* fun is correct, store in the function slot: */
  VALUES1(popSTACK()); /* return the function argument */
  Symbol_function(popSTACK()) = fun;
}

LISPFUNN(find_subr,1)
{ /* (SYS::%FIND-SUBR symbol)
 (defun sys::%find-subr (symbol)
   (assert (symbolp symbol))
   (or (get symbol 'sys::traced-definition) (symbol-function symbol))) */
  var object symbol = check_symbol(popSTACK());
  var object result = get(symbol,S(traced_definition));
  if (!boundp(result))
    result = Symbol_function(symbol);
  if (!subrp(result)) {
    pushSTACK(symbol);
    pushSTACK(S(find_subr));
    error(error_condition,GETTEXT("~S: ~S is not a system function"));
  }
  VALUES1(result);
}

LISPFUNN(proclaim_constant,2)
{ /* (SYS::%PROCLAIM-CONSTANT symbol value) turns the symbol into a constant
   and assigns a value. */
  var object symbol = check_symbol_not_symbol_macro(STACK_1);
  #if defined(MULTITHREAD)
   /* clear per thread symvalues if any */
   pushSTACK(symbol);
   clear_per_thread_symvalues(symbol);
   symbol = popSTACK();
  #endif
  var object val = STACK_0; skipSTACK(2);
  set_const_flag(TheSymbol(symbol)); /* make a constant */
  Symbol_value(symbol) = val; /* and set value */
  VALUES1(symbol); /* return symbol */
}

LISPFUNN(proclaim_symbol_macro,1)
{ /* (SYS::%PROCLAIM-SYMBOL-MACRO symbol)
   turns the symbol into a global symbol macro. */
  STACK_0 = check_symbol_not_global_special(STACK_0);
  set_symmacro_flag(TheSymbol(STACK_0)); /* Change symbol to a symbol-macro. */
  VALUES1(popSTACK()); /* return symbol */
}

LISPFUN(get,seclass_read,2,1,norest,nokey,0,NIL)
{ /* (GET symbol key [not-found]), CLTL p. 164 */
  var object symbol = check_symbol(STACK_2);
  var object result = get(symbol,STACK_1); /* search */
  if (!boundp(result)) { /* not found? */
    result = STACK_0; /* default is not-found */
    if (!boundp(result)) /* not supplied */
      result = NIL; /* else NIL. */
  }
  VALUES1(result);
  skipSTACK(3);
}

LISPFUN(getf,seclass_read,2,1,norest,nokey,0,NIL)
{ /* (GETF place key [not-found]), CLTL p. 166 */
  var gcv_object_t *plistr_ = plist_find(&STACK_2,STACK_1);
  if (plistr_ == NULL) /* property list has odd length */
    error_plist_odd(STACK_2);
  var object plistr = *plistr_;
  if (endp(plistr)) { /* key not found */
    if (eq( value1 = STACK_0, unbound)) /* default value is not-found */
      value1 = NIL; /* if not supplied, then NIL. */
    mv_count=1; skipSTACK(3); return;
  }
  /* found key */
  plistr = Cdr(plistr);
  if (atomp(plistr))
    error_plist_odd(STACK_2);
  VALUES1(Car(plistr)); skipSTACK(3);
}

LISPFUNN(putf,3)
{ /* (setf place (SYS::%PUTF place key value)) ==
     (setf (getf place key) value)
  see places.lisp: this will return NIL if place was a CONS, i.e.,
  if the list was modified "in place" and the PLACE does not have to be set */
  var gcv_object_t *tail = plist_find(&STACK_2,STACK_1);
  if (tail == NULL) error_plist_odd(STACK_2);
  var object plistr = *tail;
  if (endp(plistr)) { /* key not found => extend plist with 2 conses */
    pushSTACK(allocate_cons());
    var object cons1 = allocate_cons();
    var object cons2 = popSTACK();
    Cdr(cons1) = cons2;
    if (consp(STACK_2)) { /* can modify in-place */
      Cdr(cons2) = Cdr(STACK_2);
      Car(cons2) = Car(STACK_2);
      Car(STACK_2) = STACK_1; /* key */
      Cdr(STACK_2) = cons1;
      Car(cons1) = STACK_0; /* value */
      VALUES1(NIL);
    } else { /* prepend */
      Car(cons2) = STACK_0; /* value */
      Cdr(cons2) = STACK_2; /* tail */
      Car(cons1) = STACK_1; /* key */
      VALUES1(cons1);
    }
  } else {
    plistr = Cdr(plistr);
    if (atomp(plistr)) error_plist_odd(STACK_2);
    Car(plistr) = STACK_0; /* value */
    VALUES1(NIL);
  }
  skipSTACK(3);
}

LISPFUNN(remf,2)
{ /* (remf place key) ==
     (multiple-value-bind (new-place removed-p) (SYS::%REMF place key)
       (when (and removed (null new-place)) (setf place new-place)) removed-p)
  see places.lisp: PLACE has to be modified only if the new value is ATOM */
  var gcv_object_t *tail = plist_find(&STACK_1,STACK_0);
  if (tail == NULL) error_plist_odd(STACK_1);
  var object plistr = *tail;
  if (endp(plistr)) value2 = NIL; /* key not found => not removed */
  else {
    plistr = Cdr(plistr);
    if (atomp(plistr)) error_plist_odd(STACK_1);
    plistr = Cdr(plistr);
    if (atomp(plistr)) *tail = plistr;
    else { /* shorten the property list by 2 elements */
      Car(*tail) = Car(plistr);
      Cdr(*tail) = Cdr(plistr);
    }
    value2 = T;
  }
  value1 = STACK_1; mv_count = 2; skipSTACK(2);
}

LISPFUNNR(get_properties,2)
{ /* (GET-PROPERTIES place keylist), CLTL p. 167 */
  var object keylist = popSTACK();
  var object plist = popSTACK();
  var object plistr = plist;
  while (1) {
    if (endp(plistr))
      goto notfound;
    var object item = Car(plistr);
    if (!nullp(memq(item,keylist)))
      goto found;
    plistr = Cdr(plistr);
    if (atomp(plistr))
      goto odd;
    plistr = Cdr(plistr);
  }
 found: /* key found */
  value3 = plistr; /* 3rd value = list rest */
  value1 = Car(plistr); /* 1st value = found key */
  plistr = Cdr(plistr);
  if (atomp(plistr))
    goto odd;
  value2 = Car(plistr); /* 2nd value = value for key */
  mv_count=3; return; /* 2 values */
 odd: /* property list has odd length */
  error_plist_odd(plist);
 notfound: /* key not found */
  VALUES3(NIL,NIL,NIL); return; /* all 3 values */
}

LISPFUNN(putplist,2)
{ /* (SYS::%PUTPLIST symbol list) == (SETF (SYMBOL-PLIST symbol) list) */
  var object symbol = check_symbol(STACK_1);
  var object list = STACK_0; skipSTACK(2);
  VALUES1(Symbol_plist(symbol) = list);
}

LISPFUNN(put,3)
{ /* (SYS::%PUT symbol key value) == (SETF (GET symbol key) value) */
  var object symbol = check_symbol(STACK_2);
  var gcv_object_t *tail = plist_find(&Symbol_plist(symbol),STACK_1);
  if (tail == NULL) /* property list has odd length */
    error_sym_plist_odd(symbol);
  var object plistr = *tail;
  if (endp(plistr)) { /* key not found => extend plist with 2 conses */
    pushSTACK(allocate_cons());
    var object cons1 = allocate_cons();
    var object cons2 = popSTACK();
    Car(cons2) = STACK_0; /* value */
    Cdr(cons2) = Symbol_plist(STACK_2);
    Car(cons1) = STACK_1; /* key */
    Cdr(cons1) = cons2;
    Symbol_plist(STACK_2) = cons1;
  } else {
    plistr = Cdr(plistr);
    if (atomp(plistr)) error_sym_plist_odd(symbol); /* odd length --> error */
    Car(plistr) = STACK_0;
  }
  VALUES1(STACK_0);
  skipSTACK(3);
}

LISPFUNN(remprop,2)
{ /* (REMPROP symbol indicator), CLTL p. 166 */
  var object symbol = check_symbol(STACK_1);
  var object key = STACK_0; skipSTACK(2);
  var gcv_object_t *tail = plist_find(&Symbol_plist(symbol),key);
  if (tail == NULL) error_sym_plist_odd(symbol);
  var object plistr = *tail;
  if (endp(plistr)) value1 = NIL; /* key not found */
  else { /* key found */
    plistr = Cdr(plistr);
    if (atomp(plistr)) error_sym_plist_odd(symbol);
    *tail = Cdr(plistr); /* shorten the property list by 2 elements */
    value1 = T;
  }
  mv_count = 1;
}

LISPFUNNR(symbol_package,1)
{ /* (SYMBOL-PACKAGE symbol), CLTL p. 170 */
  var object symbol = check_symbol(popSTACK());
  VALUES1(Symbol_package(symbol));
}

LISPFUNNR(symbol_plist,1)
{ /* (SYMBOL-PLIST symbol), CLTL p. 166 */
  var object symbol = check_symbol(popSTACK());
  VALUES1(Symbol_plist(symbol));
}

LISPFUN(symbol_name,seclass_no_se,1,0,norest,nokey,0,NIL)
{ /* (SYMBOL-NAME symbol), CLTL S. 168 */
  var object symbol = check_symbol(popSTACK());
  VALUES1(Symbol_name(symbol));
}

/* (CS-COMMON-LISP:SYMBOL-NAME symbol) */
LISPFUNNR(cs_symbol_name,1)
{ /* Return the case-inverted symbol name. */
  var object symbol = check_symbol(popSTACK());
  VALUES1(string_invertcase(Symbol_name(symbol)));
}

LISPFUNNR(keywordp,1)
{ /* (KEYWORDP object), CLTL p. 170 */
  var object obj = popSTACK();
  VALUES_IF(symbolp(obj) && keywordp(obj));
}

#ifdef MULTITHREAD
global xmutex_t gensym_lock; /* global GENSYM counter lock */
global xmutex_t gentemp_lock; /* global GETEMP counter lock */
#endif

LISPFUN(gensym,seclass_read,0,1,norest,nokey,0,NIL)
{ /* (GENSYM x), CLTL S. 169, CLtL2 S. 245-246 */
  if (!boundp(STACK_0)) {
    STACK_0 = O(gensym_prefix); /* set default prefix */
    goto string_arg_supplied; /* skip next "if (stringp(STACK_0))" */
  }
  if (stringp(STACK_0)) { /* have string - use *gensym-counter* */
  string_arg_supplied:
    /* with MT if *gensym-counter* is bound in calling thread there is no need
       to lock. however this should be extremely rare case and checking for
       it will eat more cycles overall */
    var bool was_negative;
    WITH_OS_MUTEX_LOCK(0, &gensym_lock, {
      pushSTACK(Symbol_value(S(gensym_counter)));
      if (!(was_negative = R_minusp(STACK_0))) {
        Symbol_value(S(gensym_counter)) = I_1_plus_I(STACK_0);
      } else {
        Symbol_value(S(gensym_counter)) = Fixnum_0;/* reset *GENSYM-COUNTER* */
      }
      value1 = popSTACK();
    });
    if (was_negative) { /* complain about negative *GENSYM-COUNTER* */
      var object counter = value1;
      pushSTACK(counter);            /* TYPE-ERROR slot DATUM */
      pushSTACK(O(type_posinteger)); /* TYPE-ERROR slot EXPECTED-TYPE */
      pushSTACK(Fixnum_0); pushSTACK(counter);
      error(type_error,GETTEXT("The value of *GENSYM-COUNTER* was not a nonnegative integer. Old value ~S. New value ~S."));
    }
    pushSTACK(value1); /* counter */
  } else if (integerp(STACK_0)) { /* counter available */
    var object counter = check_pos_integer(popSTACK());/* ensure positive */
    pushSTACK(O(gensym_prefix)); pushSTACK(counter);
  } else /* argument with incorrect type */
    error_string_integer(popSTACK());
  /* STACK layout: STACK_0 = counter, STACK_1 = prefix */
  funcall(L(decimal_string),1); /* (sys::decimal-string counter) */
  pushSTACK(value1); /* 2nd part of string */
  VALUES1(make_symbol(coerce_imm_ss(string_concat(2))));
}

LISPFUN(gentemp,seclass_read,0,2,norest,nokey,0,NIL)
{ /* (GENTEMP prefix package), CLTL p. 170 */
  var gcv_object_t *prefix = &STACK_1;
  var gcv_object_t *package = &STACK_0;
  /* validate prefix */
  *prefix = boundp(*prefix) ? check_string(*prefix) : (object)O(gentemp_prefix);
  /* do not validate package argument - intern will barf anyway */
  do {
    WITH_OS_MUTEX_LOCK(0, &gentemp_lock, {
      value1 = O(gentemp_counter) = I_1_plus_I(O(gentemp_counter));
    });
    pushSTACK(*prefix); /* 1st part of string */
    pushSTACK(value1); /* counter */
    funcall(L(decimal_string),1); /* (sys::decimal-string counter) */
    pushSTACK(value1); /* 2nd part of string */
    pushSTACK(coerce_imm_ss(string_concat(2))); /* concatenate */
    pushSTACK(*package);
    funcall(L(intern),2); /* try to intern */
  } while (!nullp(value2));
  skipSTACK(2);
  mv_count = 1; /* single value */
}