Cell* op_car::eval_op(Cell* operand) const
{
  Cell* operand_ptr;

  no_of_operands(operand,1,1,true,true);


  if (listp(operand))
  {
    operand_ptr = car(operand);
  }
  else
  {
    throw runtime_error("No conspair for car's operation.");
  }

  if (symbolp(operand_ptr))
  {
    operand_ptr = search_symbol(get_symbol(operand_ptr),true);
  }

  if (listp(operand_ptr))
  {
    operand_ptr = eval(car(operand));
  }
  else
  {
    throw runtime_error("No conspair for car's operation.");
  }

  if (!listp(operand_ptr))
  {
    return operand_ptr;
  }
  return car(operand_ptr);
}
Exemple #2
0
VOID standard_hardware_clobber P1C(LVAL, object)
{
  LVAL addr, oblist;
  
  if (! objectp(object)) xlerror("not an object", object);
  
  addr = slot_value(object, s_hardware_address);
  
  oblist = getvalue(s_hardware_objects);
  if (! listp(oblist)) xlerror("not a list", oblist);
  
  setvalue(s_hardware_objects, xlcallsubr2(xdelete, addr, oblist));
  set_slot_value(object, s_hardware_address, NIL);
  
  send_callback_message(object, sk_clobber);
}
Exemple #3
0
/* check an item instance variable */
static LVAL check_item_ivar P2C(int, which, LVAL, value)
{
  int good=0;
  
  switch (which) {
  case 'T': good = (stringp(value) && strlen(getstring(value)) != 0); break;
  case 'K': good = (charp(value) || value == NIL); break;
  case 'M': good = (charp(value) || value == NIL || value == s_true); break;
  case 'S': good = (symbolp(value) || listp(value)); break;
  case 'A': good = (value == NIL || symbolp(value) || closurep(value) || subrp(value) || (bcclosurep(value))); break;
  case 'E': good = TRUE; value = (value != NIL) ? s_true : NIL; break;
  default:  xlfail("unknown item instance variable");
  }
  if (! good) xlerror("bad instance variable value", value);
  return(value);
}
Exemple #4
0
void printlist(int addr){
    if(IS_NIL(addr))
        printf(")");
    else
    if((!(listp(cdr(addr)))) && (! (nullp(cdr(addr))))){
        print(car(addr));
        printf(" . ");
        print(cdr(addr));
        printf(")");
    }
    else {
        print(GET_CAR(addr));    
        if(! (IS_NIL(GET_CDR(addr))))
            printf(" ");
        printlist(GET_CDR(addr));
    }
}
Exemple #5
0
/* compute the length of the result sequence */
LOCAL int findmaprlen P1C(LVAL, args)
{
  LVAL next, e;
  int len, rlen;

  for (rlen = -1, next = args; consp(next); next = cdr(next)) {
    e = car(next);
    if (! listp(e) && ! vectorp(e) && ! tvecp(e))
      xlbadtype(car(next));
    len = seqlen(e);
    if (rlen == -1)
      rlen = len;
    else
      rlen = (len < rlen) ? len : rlen;
  }
  return(rlen);
}
AbstractVector * SimpleString::adjust_vector(INDEX new_capacity,
                                             Value initial_element,
                                             Value initial_contents)
{
  if (initial_contents != NIL)
    {
      BASE_CHAR * new_chars = (BASE_CHAR *) GC_malloc_atomic(new_capacity + 1);
      if (listp(initial_contents))
        {
          Value list = initial_contents;
          for (unsigned long i = 0; i < new_capacity; i++)
            {
              new_chars[i] = char_value(car(list));
              list = xcdr(list);
            }
        }
      else if (vectorp(initial_contents))
        {
          AbstractVector * v = the_vector(initial_contents);
          for (unsigned long i = 0; i < new_capacity; i++)
            new_chars[i] = char_value(v->aref(i));
        }
      else
        signal_type_error(initial_contents, S_sequence);
      new_chars[new_capacity] = 0;
      return new_simple_string(new_capacity, new_chars);
    }
  if (_capacity != new_capacity)
    {
      BASE_CHAR * new_chars = (BASE_CHAR *) GC_malloc_atomic(new_capacity + 1);
      unsigned long limit = (_capacity < new_capacity) ? _capacity : new_capacity;
      for (unsigned long i = 0; i < limit; i++)
        new_chars[i] = _chars[i];
      if (_capacity < new_capacity)
        {
          BASE_CHAR c = char_value(initial_element);
          for (unsigned long i = _capacity; i < new_capacity; i++)
            new_chars[i] = c;
        }
      new_chars[new_capacity] = 0;
      return new_simple_string(new_capacity, new_chars);
    }
  // No change.
  return this;
}
cons_t* proc_mulf(cons_t *p, environment_t*)
{
  real_t product = 1.0;

  for ( ; !nullp(p); p = cdr(p) ) {
    cons_t *i = listp(p)? car(p) : p;

    if ( integerp(i) )
      product *= static_cast<real_t>(i->number.integer);
    else if ( realp(i) )
      // automatically convert; perform rest of computation in floats
      product *= i->number.real;
    else
      raise(runtime_exception("Cannot multiply integer with " + to_s(type_of(i)) + ": " + sprint(i)));
  }

  return real(product);
}
cons_t* deep_copy(const cons_t *p)
{
  if ( !p )
    return NULL;

  cons_t *r = new cons_t();
  memcpy(r, p, sizeof(cons_t));

  if ( listp(r) ) {
    r->car = deep_copy(r->car);
    r->cdr = deep_copy(r->cdr);
  } else if ( syntaxp(r) )
    r->syntax->transformer = deep_copy(r->syntax->transformer);
  else if ( stringp(r) )
    r->string = copy_str(r->string);

  return r;
}
Exemple #9
0
//--------eval---------------        
int eval(int addr){
	int res;
    
    //ctrl+cによる割り込みがあった場合
    if(exit_flag == 1){
    	exit_flag = 0;
        P = addr; //後で調べられるように退避
        printf("exit eval by CTRL_C_EVENT\n"); fflush(stdout);
        longjmp(buf,1);
    }
    
    if(atomp(addr)){
		if(numberp(addr))
    		return(addr);
    	if(symbolp(addr)){
    		res = findsym(addr);
            if(res == 0)
            	error(CANT_FIND_ERR, "eval", addr);
            else
            	switch(GET_TAG(res)){
                	case NUM:	return(res);
                	case SYM:	return(res);
                    case LIS:	return(res);
                	case SUBR:	return(res);
                    case FSUBR:	return(res);
                    case LAMBDA:return(GET_BIND(res));
                }	
        }
    }
    else 
    if(listp(addr)){
    	if((symbolp(car(addr))) &&(HAS_NAME(car(addr),"quote")))
    		return(cadr(addr));
        if(numberp(car(addr)))
        	error(ARG_SYM_ERR, "eval", addr);
    	if(subrp(car(addr)))
    		return(apply(car(addr),evlis(cdr(addr))));
    	if(fsubrp(car(addr)))
            return(apply(car(addr),cdr(addr)));
    	if(lambdap(car(addr)))
    		return(apply(car(addr),evlis(cdr(addr))));	  
    }
    error(CANT_FIND_ERR, "eval", addr);
}
cons_t* proc_addf(cons_t *p, environment_t*)
{
  real_t sum = 0.0;

  for ( ; !nullp(p); p = cdr(p) ) {
    cons_t *i = listp(p)? car(p) : p;

    if ( integerp(i) )
      sum += static_cast<real_t>(i->number.integer);
    else if ( realp(i) )
      sum += i->number.real;
    else if ( rationalp(i) )
      sum += real(i->number.rational)->number.real;
    else
      raise(runtime_exception("Cannot add real with " + to_s(type_of(i)) + ": " + sprint(i)));
  }

  return real(sum);
}
Exemple #11
0
AbstractVector * SimpleBitVector::adjust_vector(INDEX new_capacity,
        Value initial_element,
        Value initial_contents)
{
    if (initial_contents != NIL)
    {
        SimpleBitVector * bv = new_simple_bit_vector(new_capacity);
        if (listp(initial_contents))
        {
            Value list = initial_contents;
            for (INDEX i = 0; i < new_capacity; i++)
            {
                bv->inline_setbit(i, check_bit(car(list)));
                list = xcdr(list);
            }
        }
        else if (vectorp(initial_contents))
        {
            AbstractVector * v = the_vector(initial_contents);
            for (INDEX i = 0; i < new_capacity; i++)
                bv->inline_setbit(i, check_bit(v->aref(i)));
        }
        else
            signal_type_error(initial_contents, S_sequence);
        return bv;
    }
    if (_capacity != new_capacity)
    {
        SimpleBitVector * bv = new_simple_bit_vector(new_capacity);
        INDEX limit = (_capacity < new_capacity) ? _capacity : new_capacity;
        for (INDEX i = 0; i < limit; i++)
            bv->inline_setbit(i, inline_getbit(i));
        if (_capacity < new_capacity)
        {
            BIT bit = check_bit(initial_element);
            for (INDEX i = _capacity; i < new_capacity; i++)
                bv->inline_setbit(i, bit);
        }
        return bv;
    }
    // no change
    return this;
}
Exemple #12
0
void os_link_runtime()
{
#ifdef LISP_FEATURE_SB_DYNAMIC_CORE
    char *link_target = (char*)(intptr_t)LINKAGE_TABLE_SPACE_START;
    void *validated_end = link_target;
    lispobj symbol_name;
    char *namechars;
    boolean datap;
    void* result;
    int j;

    if (lisp_linkage_table_n_prelinked)
        return; // Linkage was already performed by coreparse

    struct vector* symbols = VECTOR(SymbolValue(REQUIRED_FOREIGN_SYMBOLS,0));
    lisp_linkage_table_n_prelinked = fixnum_value(symbols->length);
    for (j = 0 ; j < lisp_linkage_table_n_prelinked ; ++j)
    {
        lispobj item = symbols->data[j];
        datap = listp(item);
        symbol_name = datap ? CONS(item)->car : item;
        namechars = (void*)(intptr_t)(VECTOR(symbol_name)->data);
        result = os_dlsym_default(namechars);

        if (link_target == validated_end) {
            validated_end = (char*)validated_end + os_vm_page_size;
#ifdef LISP_FEATURE_WIN32
            os_validate_recommit(link_target,os_vm_page_size);
#endif
        }
        if (result) {
            arch_write_linkage_table_entry(link_target, result, datap);
        } else { // startup might or might not work. ymmv
            printf("Missing required foreign symbol '%s'\n", namechars);
        }

        link_target += LINKAGE_TABLE_ENTRY_SIZE;
    }
#endif /* LISP_FEATURE_SB_DYNAMIC_CORE */
#ifdef LISP_FEATURE_X86_64
    SetSymbolValue(CPUID_FN1_ECX, (lispobj)make_fixnum(cpuid_fn1_ecx), 0);
#endif
}
Exemple #13
0
/* get compound item's data sequence */
LVAL compounddataseq P1C(LVAL, x) 
{
  switch (ntype(x)) {
  case OBJECT:
    {
      LVAL seq = send_message(x, sk_data_seq);
      if (! listp(seq) && ! vectorp(seq) && ! tvecp(seq))
	xlerror("not a sequence", seq);
      return(seq);
    }
  case DARRAY: return(getdarraydata(x));
  case CONS:
  case VECTOR:
  case TVEC:   return(x);
  case SYMBOL:
    if (null(x)) return(x);
    /* fall through */
  default: return(xlbadtype(x));
  }
}
Exemple #14
0
/* Make sequence into a compound item of the same shape as form */
LVAL makecompound P2C(LVAL, form, LVAL, seq)
{
  LVAL result;

  xlsave1(result);
  if (listp(form))
    result = coerce_to_list(seq);
  else if (vectorp(form) || tvecp(form))
    result = coerce_to_tvec(seq, s_true);
  else if (darrayp(form)) {
    result = coerce_to_tvec(seq, s_true);
    result = newdarray(getdarraydim(form), result);
  }
  else if (objectp(form)) {
    result = send_message_1L(form, sk_make_data, seq);
  }
  else xlerror("not a compound data item", form);

  xlpop();
  return(result);
}
Exemple #15
0
Cell* ProcedureCell::  apply(Cell*args)
{     
      map<string,Cell*> local_table;
      if(this->get_formals()!=nil)
      {
         Cell* formal_count=this->get_formals();
         Cell* argument_count=args;
         if(!listp(args)) 
         {throw runtime_error("Must receice a list of arguments");}
         if(operand_num(this->get_formals())!=operand_num(args))
         {throw runtime_error("Wrong number of arguments");}
         else{
            //cout<<"1"<<endl;
            while (formal_count!=nil)
            {
               local_table[formal_count->get_car()->get_symbol()]=eval(argument_count->get_car());
               formal_count=formal_count->get_cdr();
               argument_count=argument_count->get_cdr();
            }
            map_list.push_front(local_table);//the new table is push in the front
         }
      }
      Cell* eval_count=this->get_body();//cout<<"2 "<<*eval_count<<endl;
      Cell* result;
      try{
      while (eval_count->get_cdr()!=nil)
      {  //cout<<"3"<<endl;
         eval(eval_count->get_car());//cout<<"4"<<endl;
         eval_count=eval_count->get_cdr();
         
      }
      result=eval(eval_count->get_car());
      }
      catch(runtime_error & e)
      {map_list.pop_front();throw e;}
      if(this->get_formals()!=nil) map_list.pop_front();
      return result;
} 
// ### make-structure-class name include slots => class
Value SYS_make_structure_class(Value name, Value slots, Value include)
{
  if (!symbolp(name))
    return signal_type_error(name, S_symbol);
  if (!listp(slots))
    return signal_type_error(name, S_list);
  StructureClass * c = new StructureClass(name, slots);
  if (include != NIL)
    {
      Value included_class = find_class(include);
      if (included_class == NULL_VALUE)
        {
          String * message = new String(::prin1_to_string(include));
          message->append(" does not name a class.");
          return signal_lisp_error(message);
        }
      c->set_cpl(make_cons(make_value(c), the_class(included_class)->cpl()));
    }
  else
    c->set_cpl(make_cons(make_value(c), the_class(C_structure_object)->cpl()));

  return add_class(name, make_value(c));
}
Exemple #17
0
static cons_t* verify_library_name(cons_t* p)
{
  if ( !listp(p) )
    raise(syntax_error(format(
      "The library name must be a list, not %s",
        indef_art(to_s(type_of(p))).c_str())));

  /*
   * R7RS: <library name> is a list whose members are ...
   */
  for ( cons_t *q = p; !nullp(q); q = cdr(q) ) {
    // ... identifiers
    if ( type_of(car(q)) == SYMBOL )
      continue;

    // ... and exact nonnegative integers.
    if ( type_of(car(q)) == INTEGER && car(q)->number.integer >= 0 )
      continue;

    raise(syntax_error("Invalid library name: " + sprint(p)));
  }

  return p;
}
Exemple #18
0
static LVAL elementlist P1C(LVAL, x)
{
  LVAL next, last, result;
  
  if (!compoundp(x)) result = consa(x);
  else {
    xlprot1(x);
    x = compounddataseq(x);
    x = (listp(x)) ? copylist(x) : coerce_to_list(x);
    if (all_simple(x)) result = x;
    else {
      for (next = x; consp(next); next = cdr(next))
        rplaca(next, elementlist(car(next)));
      result = car(x);
      last = lastcdr(car(x));
      for (next = cdr(x); consp(next); next = cdr(next)) {
        rplacd(last, car(next));
        last = lastcdr(car(next));
      }
    }
    xlpop();
  }
  return(result);
}
Cell* op_nullp::eval_op(Cell* operand) const
{
  Cell* operand_ptr;

  no_of_operands(operand,1,1,true,true);

  operand_ptr = car(operand);

  if (listp(operand_ptr))
  {
    operand_ptr = eval(operand_ptr);
  }
  else if (symbolp(car(operand)))
  {
    operand_ptr = search_symbol(get_symbol(car(operand)),true);
  }

  if (nullp(operand_ptr))
  {
    return make_int(1);
  }
  else
    return make_int(0);
}
Cell* eval(Cell* const c)
{
	initialize(c);
	if (c == nil)
		throw RuntimeError("Empty list\n     : At Cell* eval()");
	string s;
	if (!listp(c) && symbolp(c) && fstack.empty())
		throw RuntimeError("Attempt to reference an unbound variable \"" + get_symbol(c) + "\"" + "\n     : At Cell* eval()");
	else if (!listp(c) && !fstack.empty() && symbolp(c)) {
		s = get_symbol(c);
		CellMap::iterator find_key;
		if (fstack.size() > 1) {
			find_key = fstack[1].find(s);
			if (find_key != fstack[1].end())
				return ceval(find_key->second);
		}
		find_key = fstack[0].find(s);
		if (find_key == fstack[0].end())
			throw RuntimeError("Attempt to reference an unbound variable \"" + s + "\"" + "\n     : At Cell* eval()");
		return ceval(find_key->second);
	}
	if (!listp(c) && !symbolp(c))
		return c;
	else if (listp(c) && !symbolp(car(c)) && !listp(car(c)))
		throw RuntimeError("Invalid operator\n     : At Cell* eval()");
	else if (listp(car(c))) {
		if (nullp(car(c)))
			throw RuntimeError("Cannot evaluate a null expression\n     : At Cell* eval()");
		return ceval(c); // pass it to ceval if it's a double list
	}
	s = get_symbol(car(c));
	vector<string>::iterator find_op = locate(op.begin(), op.end(), s);
	if (find_op != op.end())
		return ceval(c);
	else if (fstack.size() > 1) {
		CellMap::iterator find_key = fstack[1].find(s);
		if (find_key != fstack[1].end())
			return ceval(c);// return apply(ceval(find_key->second), cdr(c));
	}
	throw RuntimeError("Invalid operator \"" + s + "\"\n     : At Cell* eval()");
}
Exemple #21
0
/*
 * Parse (define-library ...) form into given environment, with the
 * following format:
 *
 * (define-library <library name>
 *   <library declaration> ...)
 *
 * where <library declaration> is any of:
 *
 * - (export <export spec> ...)
 * - (import <import set> ...)
 * - (begin <command or definition> ...)
 * - (include <filename1> <filename2> ...)
 * - (include-ci <filename1> <filename2> ...)
 * - (cond-expand <cond-expand clause> ...)
 */
static library_t* define_library(cons_t* p, const char* file)
{
  library_t *r = new library_t();
  cons_t *exports = nil();

  // find current dir for resolving include and include-ci
  std::string curdir = sdirname(file);

  // define-library
  if ( symbol_name(caar(p)) != "define-library" )
    raise(syntax_error(format(
      "Imported file does not begin with define-library: %s", file)));

  // <library name>
  r->name = verify_library_name(cadar(p));

  // A <library declaration> can be either ...
  for ( p = cdr(cdar(p)); !nullp(p); p = cdr(p) ) {
    cons_t *id   = caar(p);
    cons_t *body = cdar(p);
    std::string s = symbol_name(id);

    if ( s == "export" ) {
      exports = body;
      continue;
    }

    if ( s == "import" ) {
      // TODO: Make sure that proc_import does not override
      //       r->internals->outer
      proc_import(body, r->internals);
      continue;
    }

    if ( s == "begin" ) {
      eval(car(p), r->internals);
      continue;
    }

    if ( s == "include" ) {
      eval(splice(list(symbol("begin")),
                  include(body, r->internals, curdir.c_str())),
           r->internals);
      continue;
    }

    if ( s == "include-ci" ) {
      eval(splice(list(symbol("begin")),
                  include_ci(body, r->internals, curdir.c_str())),
           r->internals);
      continue;
    }

    if ( s == "cond-expand" ) {
      eval(cond_expand(body, r->internals), r->internals);
      continue;
    }
  }

  // copy exports into exports-environemnt
  for ( p = exports; !nullp(p); p = cdr(p) ) {

    // handle renaming
    if ( listp(car(p)) && length(car(p))==3 &&
         symbol_name(caar(p))=="rename" )
    {
      assert_type(SYMBOL, cadar(p));
      assert_type(SYMBOL, caddar(p));

      std::string internal_name = symbol_name(cadar(p));
      std::string external_name = symbol_name(caddar(p));

      r->exports->define(external_name,
                         r->internals->lookup(internal_name));
    } else if ( listp(car(p)) )
      raise(syntax_error("(export <spec> ...) only allows (rename x y)"));
    else if ( type_of(car(p)) == SYMBOL ) {
      r->exports->define(symbol_name(car(p)),
                         r->internals->lookup(symbol_name(car(p))));
    } else
      raise(syntax_error(
        "(export <spec> ...) requires <spec> to be "
        "either an identifier or a pair of them."));
  }

  return r;
}
Exemple #22
0
std::string sprint(const cons_t* p)
{
  std::string s;
  return sprint(listp(p) ? cons(p) : p, s, true);
}
Exemple #23
0
Cell* eval(Cell* const c)
{
  // when root cell is empty, throw an error.
  judge_nil_cell(c,"begin");
  
  // when root cell is a int or double cell, return a copy.
  if (intp(c) || doublep(c) || procedurep(c)) {
    return c -> deep_copy();
  }

  //if c is a symbol, there are several situations
  //if c is in the local map, which means c is a procedurecell.
  //if c is in the global map, which menas c is defined as some other value.
  if (symbolp(c)) {
    string var = get_symbol(c);
    // first check if the symbol is defined at a local space
    // if it is, then return a copy of it.
    if (!my_stack.empty()) {
      if (my_stack.top().count(var)) {
	bstmap<string,Cell*> temp = my_stack.top();
	if (nullp(temp[var])) return nil;
	return temp[var] -> deep_copy();
      }
    }
    // then check if the symbol is defined in the global map
    if (symbol_table.count(var)) {
      if (nullp(symbol_table[var])) return nil;
      return symbol_table[var] -> deep_copy();
    }
    throw symbol_undefined_error("the variable " + var + " is not defined in the map");
  }

  // Then we know the 'c' cell must be a root of list
  Cell* oper_cell = NULL;
  string oper;
  if (listp(car(c))) {
    oper_cell = eval(car(c));
    // oper cell should be the operator (primitive or procedure cell)
    // it cannot be an empty operator
    if (nullp(oper_cell)) {
      throw invalid_operator_error("you cannot use an empty operator");
    }
    // if the first element of the expression is a list, the result evaluating it must be a procedure
    if (!procedurep(oper_cell)) {
      throw invalid_operator_error("cannot apply a value that is not a function");
    }
    // then return a copy of this procedure cell
    if (procedurep(oper_cell)) {
      Cell* argu_list = nullp(cdr(c)) ? nil : cdr(c) -> deep_copy();
      return oper_cell -> apply(argu_list);
    }
  }

  oper_cell = car(c) -> deep_copy();
  // the operator cannot be a int or double
  if (!symbolp(oper_cell)) {
    throw invalid_operator_error("The input operator is not a procedure or primitive type");
  }
  oper = get_symbol(oper_cell);

  /**
   * the ceiling operator
   * using oper_ceil(), which is a virtual function in Cell.
   */
  if (oper == "ceiling") {
    judge_num_argu(c,oper); // check validation
    Cell* temp_cell = eval(car(cdr(c)));
    judge_nil_cell(temp_cell,oper); // check validation
    Cell* result = temp_cell -> oper_ceil();
    delete oper_cell;
    delete temp_cell;
    return result;
  }

  /**
   * the floor operator
   * using oper_floor(), which is a virtual function in Cell.
   */
  if (oper == "floor") {
    judge_num_argu(c,oper); // check validation
    Cell* temp_cell = eval(car(cdr(c)));
    judge_nil_cell(temp_cell,oper); //check validation
    Cell* result = temp_cell -> oper_floor();
    delete oper_cell;
    delete temp_cell;
    return result;
  }

  /**
   * the add operator
   * using oper_add(), which is a virtual function in Cell.
   */
  if (oper == "+") {
    // by "+" convention, when evaluate a single plus operator, return 0.
    if (nullp(cdr(c))) {
      delete oper_cell; 
      return make_int(0);
    }
    int size = cdr(c) -> cons_size();
    // use cell:result as a initial cell
    Cell* result = make_int(0);
    Cell* next_elem = cdr(c);
    
    for (int i=1; i<=size; i++) {
      Cell* next_temp = eval(car(next_elem));
      judge_nil_cell(next_temp,oper);
      result = result -> oper_add(next_temp);
      delete next_temp; //delete temporary cell in every step.
      next_elem = cdr(next_elem);
    }
    
    delete oper_cell;
    return result;
  }

  /**
   * the minus operator
   * using oper_minus(), which is a virtual function in Cell.
   */
  if (oper == "-") {
    judge_num_argu(c,oper);
    int size = cdr(c) -> cons_size();
    Cell* result = eval(car(cdr(c)));
    judge_nil_cell(result,oper);
    // by "-" convention, when only one operand, return its inverse.
    if (size == 1) {
      result = result -> oper_minus(nil);
      delete oper_cell;
      return result;
    }
    Cell* next_elem = cdr(cdr(c));
    
    for (int i=1; i<size; i++) {
      Cell* next_temp = eval(car(next_elem));
      judge_nil_cell(next_temp,oper);
      result = result -> oper_minus(next_temp);
      delete next_temp; //delete temporary cell in every step.
      next_elem = cdr(next_elem);
    }

    delete oper_cell;
    return result;
  }

  /**
   * the multiply operator
   * using oper_multiply(), which is a virtual function in Cell.
   */
  if (oper == "*") {
    if (nullp(cdr(c))) {
      delete oper_cell;
      return make_int(1);
    }
    int size = cdr(c) -> cons_size();
    Cell* result = make_int(1);
    Cell* next_elem = cdr(c);

    for (int i=1; i<=size; i++) {
      Cell* next_temp = eval(car(next_elem));
      judge_nil_cell(next_temp,oper);
      result = result -> oper_multiply(next_temp);
      delete next_temp; //delete temporary cell in every step.
      next_elem = cdr(next_elem);
    }

    delete oper_cell;
    return result;
  }

  /**
   * the division operator
   * using oper_divide(), which is a virtual function in Cell.
   */
  if (oper == "/") {
    judge_num_argu(c,oper);
    int size = cdr(c) -> cons_size();
    Cell* result = eval(car(cdr(c)));
    judge_nil_cell(result,oper);
    // by "/" convention, when only one operand, return its inverse.
    if (size == 1) {
      result = result -> oper_divide(nil);
      delete oper_cell;
      return result;
    }
    Cell* next_elem = cdr(cdr(c));
    
    for (int i=1; i<size; i++) {
      Cell* next_temp = eval(car(next_elem));
      judge_nil_cell(next_temp,oper);
      result = result -> oper_divide(next_temp);
      delete next_temp; //delete temporary cell on every step.
      next_elem = cdr(next_elem);
    }
    
    delete oper_cell;
    return result;
  }

  /**
   * the if operator
   * using oper_if(), which is a virtual function in Cell.
   */
  if (oper == "if") {
    judge_num_argu(c,oper); // check validation
    int size = cdr(c) -> cons_size();
    Cell* judge_cell = cdr(c); // the first operand after if
    Cell* judge_cell_temp = eval(car(judge_cell));
    Cell* true_cell = cdr(judge_cell); // the second operand after if
    // if judge cell is a empty list, return true_cell
    if (nullp(judge_cell_temp)) {
      delete judge_cell_temp; 
      delete oper_cell;
      return eval(car(true_cell));
    }
    
    Cell* condition = judge_cell_temp -> oper_if();
    // condition must be an IntCell from the implementation of Cell.cpp
    if (get_int(condition)) {
      Cell* true_cell_temp = eval(car(true_cell));
      delete judge_cell_temp;
      delete oper_cell;
      return true_cell_temp;
    } else {
      Cell* false_cell = nil;
      // if there are only two operand, which is an undefined behavior
      // we will let it return the second operand
      if (size == 2) {
	false_cell = eval(car(true_cell)); 
      } else {
	false_cell = eval(car(cdr(true_cell)));
      }
      delete judge_cell_temp;
      delete oper_cell;
      return false_cell;
    }
  }	  
  
  /**
   * the quote operator
   */
  if (oper == "quote") {
    judge_num_argu(c,oper); // check validation
    delete oper_cell;
    if (nullp(car(cdr(c)))) return nil;
    return car(cdr(c)) -> deep_copy();
  }
 
  /**
   * the cons operator
   * using cons() which is a function in cons.hpp.
   */
  if (oper == "cons") {
    judge_num_argu(c,oper); // check validation
    Cell* car_new = eval(car(cdr(c)));
    Cell* cdr_new = eval(car(cdr(cdr(c))));
    if (!listp(cdr_new)) {
      throw invalid_operator_error("cdr must either be nil or a conspair");
    }
    Cell* result = cons(car_new, cdr_new);
    delete oper_cell;
    return result;
  }

  /**
   * the car operator
   * using car() which is a function in cons.hpp.
   */
  if (oper == "car") {
    judge_num_argu(c,oper);
    Cell* temp = eval(car(cdr(c)));
    Cell* result = nullp(car(temp)) ? nil : car(temp) -> deep_copy();
    delete temp;
    delete oper_cell;
    return result;
  }

  /**
   * the cdr operator
   * using cdr() which is a function in cons.hpp.
   */
  if (oper == "cdr") {
    judge_num_argu(c,oper);
    Cell* temp = eval(car(cdr(c)));
    Cell* result = nullp(cdr(temp)) ? nil : cdr(temp) -> deep_copy();
    delete temp;
    delete oper_cell;
    return result;
  }
  

  /**
   * the nullp operator
   * using nullp() which is a function in cons.hpp.
   */
  if (oper == "nullp") {
    judge_num_argu(c,oper);
    Cell* temp_cell = eval(car(cdr(c)));
    if(nullp(temp_cell)) {
      delete temp_cell;
      delete oper_cell;
      return make_int(1);
    } else {
      delete temp_cell;
      delete oper_cell;
      return make_int(0);
    }
  } 

  /**
   * the define operator
   * using map to record relation between string and cell
   */
  if (oper == "define") {
    judge_num_argu(c,oper);
    Cell* key_cell = car(cdr(c));
    Cell* next_cell = car(cdr(cdr(c)));
    if (!symbolp(key_cell)) {
      throw operate_on_nil_error("define operand must be a symbol");
    }
    Cell* mapped_cell = eval(next_cell);
    string key = get_symbol(key_cell);
    if (symbol_table.count(key)) {
      throw invalid_operand_error("Cannot redefine a variable");
    }
    symbol_table.insert(make_pair(key,mapped_cell));
    delete oper_cell;
    return nil;
  }
  
  /**
   * the less operator
   * using oper_less(), which is a virtual function in Cell.
   */
  if (oper == "<") {
    //by convention, it will return 1 when zero argument.
    if (nullp(cdr(c))) {
      return make_int(1);
    }
    int size = cdr(c) -> cons_size();
    //when one argument, return itself.
    if (size == 1) {
      Cell* result = eval(car(cdr(c)));
      judge_nil_cell(result,oper);
      result = result -> oper_less(nil);
      delete oper_cell;
      return result;
    }
    Cell* this_elem = cdr(c);
    Cell* next_elem = cdr(cdr(c));
    int condition = 1;
    for (int i=1; i<size; i++) {
      Cell* next_temp = eval(car(next_elem));
      judge_nil_cell(next_temp,oper);
      Cell* this_temp = eval(car(this_elem));
      judge_nil_cell(this_temp,oper);
      Cell* judge_cell = this_temp -> oper_less(next_temp);
      // if there is one pair such that 'this' bigger than 'next', condition will be zero
      condition *= get_int(judge_cell); 
      // delete temporary cell
      delete judge_cell;
      delete this_temp;
      delete next_temp;
      this_elem = cdr(this_elem);
      next_elem = cdr(next_elem);
    }
    delete oper_cell;
    return make_int(condition);
  }

  /**
   * the not operator
   * using oper_not(), which is a virtual function in Cell.
   */
  if (oper == "not") {
    judge_num_argu(c,oper);
    Cell* operand = eval(car(cdr(c)));
    if (nullp(operand)) {
      delete oper_cell;
      return make_int(0);
    }
    Cell* result = operand -> oper_not();
    delete operand;
    delete oper_cell;
    return result;
  }

  /**
   * the print operator
   * print the result and return nil cell
   */
  if (oper == "print") {
    judge_num_argu(c,oper);
    Cell* result = eval(car(cdr(c)));
    if (nullp(result)) {
      cout << "()" << endl;
      return nil;
    }
    cout << *result << endl;
    delete oper_cell;
    delete result;
    return nil;
  }

  /**
   * the eval operator
   * evaluate the result and return nil
   */
  if (oper == "eval") {
    judge_num_argu(c,oper);
    Cell* expr = eval(car(cdr(c)));
    Cell* result = eval(expr);
    delete oper_cell;
    return result;
  }

  /**
   * the lambda operator
   * a new function
   */
  if (oper == "lambda") {
    judge_num_argu(c,oper);
    Cell* formal_m = nullp(car(cdr(c))) ? nil : car(cdr(c)) -> deep_copy();
    // since the formal part must be a symbol or list(can be empty)
    if (!listp(formal_m) && !symbolp(formal_m) && !nullp(formal_m)) {
      throw invalid_operand_error("the type of formal part should be list or symbol");
    }
    Cell* body_m = nullp(cdr(cdr(c))) ? nil : cdr(cdr(c)) -> deep_copy();
    delete oper_cell;
    return lambda(formal_m,body_m);
  }

  /**
   * the apply operator
   * followed by a function and a list of arguments
   */
  if (oper == "apply") {
    judge_num_argu(c,oper);
    Cell* procedure = eval(car(cdr(c)));
    if (!procedurep(procedure)) {
      throw invalid_operator_error("cannot apply a value that is not a function");
    }
    Cell* argu_list = eval(car(cdr(cdr(c))));
    if (!listp(argu_list)) {
      throw invalid_operand_error("the second operand after apply function must be a list");
    }
    Cell* result = procedure -> apply(argu_list);
    delete procedure;
    delete argu_list;
    delete oper_cell;
    return result;
  }


  /*
   * the let operator 
   * which allow define local variable before function definition
   */
  if (oper == "let") {
    judge_num_argu(c,oper);
    Cell* var_definition = car(cdr(c));
    Cell* func_body = car(cdr(cdr(c)));
    bstmap<string,Cell*> local_map;
    // According to the specification, the variable definition part must be list 
    if (!listp(var_definition)) {
      throw invalid_operand_error("In let function, the varible definition must be a list");
    }
    int size = car(var_definition) -> cons_size();
    for (int i=0; i<size; i++) {
      Cell* begin_cell = car(var_definition);
      if (!listp(begin_cell)) {
	throw invalid_operand_error("In let function, the varible definition must be a list");
      }
      int sub_size = begin_cell -> cons_size();
      // When you want to define a variable, you can only give a symbol and a value, so the size should be 2
      if (sub_size != 2) {
	throw wrong_num_argu_error("When define local variable, the size of list must be 2");
      }
      string key = get_symbol(car(begin_cell));
      Cell* argu = car(cdr(begin_cell));
      local_map.insert(make_pair(key,argu));
      var_definition = cdr(var_definition);
    }
    my_stack.push(local_map);
    return eval(func_body);
  }

  // If the oper is not the above primitive operator, then check whether they are in the global map
  // If it is, follow the similar step declared above
  if (symbol_table.count(oper)) {
    if (procedurep(symbol_table[oper])) {
      Cell* procedure = symbol_table[oper] -> deep_copy();
      Cell* argu_list = nullp(cdr(c)) ? nil : cdr(c) -> deep_copy();
      Cell* result = procedure -> apply(argu_list);
      delete oper_cell;
      delete procedure;
      delete argu_list;
      return result;
    }
  }
  throw invalid_operator_error("this operator is invalid");
}
Exemple #24
0
AbstractVector * Vector_UB32::adjust_vector(INDEX new_capacity,
                                            Value initial_element,
                                            Value initial_contents)
{
  if (initial_contents != NIL)
    {
      // "If INITIAL-CONTENTS is supplied, it is treated as for MAKE-ARRAY.
      // In this case none of the original contents of array appears in the
      // resulting array."
      unsigned int * new_data =
        (unsigned int *) GC_malloc_atomic(new_capacity * sizeof(unsigned int));
      if (listp(initial_contents))
        {
          Value list = initial_contents;
          for (INDEX i = 0; i < new_capacity; i++)
            {
              new_data[i] = check_ub32(car(list));
              list = xcdr(list);
            }
        }
      else if (vectorp(initial_contents))
        {
          AbstractVector * v = the_vector(initial_contents);
          for (INDEX i = 0; i < new_capacity; i++)
            new_data[i] = check_ub32(v->aref(i));
        }
      else
        signal_type_error(initial_contents, S_sequence);
      _data = new_data;
    }
  else
    {
      if (_data == NULL)
        {
          // displaced array
          _data = (unsigned int *) GC_malloc_atomic(new_capacity * sizeof(unsigned int));
          INDEX limit = (_capacity < new_capacity) ? _capacity : new_capacity;
          for (INDEX i = 0; i < limit; i++)
            _data[i] = check_ub32(_array->aref(i + _offset));
          unsigned int n = check_ub32(initial_element);
          for (INDEX i = _capacity; i < new_capacity; i++)
            _data[i] = n;
        }
      else if (_capacity != new_capacity)
        {
          unsigned int * new_data =
            (unsigned int *) GC_malloc_atomic(new_capacity * sizeof(unsigned int));
          INDEX limit = (_capacity < new_capacity) ? _capacity : new_capacity;
          for (INDEX i = 0; i < limit; i++)
            new_data[i] = _data[i];
          unsigned int n = check_ub32(initial_element);
          for (INDEX i = _capacity; i < new_capacity; i++)
            new_data[i] = n;
          _data = new_data;
        }
    }

  _capacity = new_capacity;

  // "The consequences are unspecified if array is adjusted to a size smaller
  // than its fill pointer without supplying the fill-pointer argument so that
  // its fill-pointer is properly adjusted in the process."
  if (_fill_pointer > _capacity)
    _fill_pointer = _capacity;

  _array = NULL;
  _offset = 0;

  return this;
}
Exemple #25
0
int f_listp(int arglist){
	if(listp(car(arglist)))
    	return(makeT());
    else
    	return(makeNIL());
}
Exemple #26
0
/**
 * \brief The evaluation function that calculates the parsed s-expression tree
 * \param c A constant pointer to a Cell instance, which is the root of the tree to be computed
 * \return A pointer to the Cell containing the final answer.
 */
Cell* eval(Cell* const c)
{
  if (nullp(c)) {
    error_handler("s-expression invalid: root of tree is nil");
  }

  if (intp(c) || doublep(c) || symbolp(c)){
    return deep_copy(c);
  }
  
  if (listp(c)) {
    //get car of c
    //using eval will automatically evaluate the subtree, if car(c) is itself a conspair
    Cell* car_value = eval(car(c));
    
    //if car is a symbol cell (it must, otherwise the eval() begins at wrong place)
    if (symbolp(car_value)){
      //get the symbol
      //case 1: +
      if (get_symbol(car_value) == "+"){
	
	//delete car_value as it's not needed any more
	delete car_value;

	//temporary sums variables
	double double_sum = 0;
	int int_sum = 0;
	bool sum_is_double = false;

	//Cell pointer to the current working cell
	Cell* current_cell = cdr(c);

	//iterate every cons pair until meet a nil cdr
	while (!nullp(current_cell)) {

	  //current_cell is not nil, and it should be a conspair
	  if (!listp(current_cell)) {
	    error_handler("cdr must be nil or conspair");
	  }

	  //pointer to the cell that contains the value to be added
	  //here eval could be used against a conspair or a int/double cell
	  Cell* value_cell = eval(car(current_cell));
	  
	  //deal with value_cell, see if it's int or not
	  if (intp(value_cell)) {
	    if (sum_is_double) {
	      double_sum += get_int(value_cell);
	    } else {
	      int_sum += get_int(value_cell);
	    }
	  } else if (doublep(value_cell)) {
	    //if value_cell is not a double cell
	    if (sum_is_double) {
	      double_sum += get_double(value_cell);
	    } else {
	      //migrate int_sum to double_sum and do related clean-ups
	      double_sum = int_sum;
	      int_sum = 0;
	      sum_is_double = true;
	      
	      double_sum += get_double(value_cell);
	    }
	  } else {
	    if (!nullp(value_cell)) delete value_cell;
	    error_handler("s-expression invalid: + operands invalid");
	  }
	  if (!nullp(value_cell)) delete value_cell;
	  //move current_cell forward;
	  current_cell = cdr(current_cell);
	}
	
	return sum_is_double ? make_double(double_sum) : make_int(int_sum);
      }
      //case 2: ceiling
      else if (get_symbol(car_value) == "ceiling") {
	//delete car_value as it's no longer needed
	delete car_value;

	//current working cell
	Cell* current_cell = cdr(c);

	if (nullp(current_cell) || !listp(current_cell)) error_handler("s-expression invalid: invalid ceiling operand!");

	if (!nullp(cdr(current_cell))) error_handler("s-expression invalid: ceiling on more than one operands");
	
	//take the ceiling and return
	Cell* returned_value = eval(car(current_cell));
	if (intp(returned_value)){
	  delete returned_value;
	  error_handler("s-expression invalid: ceiling on integer!");
	} else if (doublep(returned_value)){
	  int ceilinged_value = int(get_double(returned_value));
	  if (ceilinged_value < get_double(returned_value)) ++ceilinged_value;
	  delete returned_value;
	  return make_int(ceilinged_value);
	} else {
	  if(!nullp(returned_value)) delete returned_value;
	  error_handler("s-expression invalid: ceiling on symbol!");
	}
      }
      //case 3: if
      else if (get_symbol(car_value) == "if") {
	//delete car_value as it's no longer needed
	delete car_value;
	
	//temporary Cell pointers;
	Cell* condition = cdr(c);
	if (nullp(condition) || !listp(condition)) error_handler("s-expression invalid: condition is not a conspair");
	Cell* if_true = cdr(condition);
	if (nullp(if_true) || !listp(if_true)) error_handler("s-expression invalid: the true return value is not a cospair");
	Cell* if_false = cdr(if_true); 

	//directly return the second parameter if the third doesn't exist
	if (nullp(if_false)) {
	  return eval(car(if_true));
	} else {
	  if (!nullp(cdr(if_false))) error_handler("s-expression invalid: if operator on more than three operands");
	  
	  Cell* condition_cell = eval(car(condition));
	  bool flag = false;
	  
	  //retrieve values according to their types
	  if (intp(condition_cell)){
	    flag = get_int(condition_cell) ? true : false;
	  } else if (doublep(condition_cell)) {
	    flag = get_double(condition_cell) ? true : false;
	  } else if (symbolp(condition_cell)) {
	    flag = get_symbol(condition_cell)!="" ? true : false;
	  } else {
	    if(!nullp(car_value)) delete condition_cell;
	    error_handler("s-expression invalid: condition operand invalid to if");
	  }

	  if(!nullp(car_value)) delete condition_cell;
	  
	  return flag ? eval(car(if_true)) : eval(car(if_false));
	}
      } else {
	//delete car_value as it's no longer needed
	delete car_value;
	
	error_handler("s-expression invalid: operator not one of +, ceiling or if");
      }
    } else {
      //delete car_value as it's no longer needed
      if(!nullp(car_value)) delete car_value;
	
      //value_car is not a symbol cell
      error_handler("s-expression invalid: the first element of the tree/subtree is not a proper operator");
    }
  }
}
Exemple #27
0
int f_listp(int arglist){
    if(listp(car(arglist)))
        return(T);
    else
        return(NIL);
}
Exemple #28
0
/**
 * \brief Check the number of elements in the list is legal or not.
 * \param c The root of the subtree to be checked.
 * \param min The minimum allowed length of the list.
 * \param max The maximum allowed length of the list, by default there's no limit in maximum.
 * \return True iff c is a valid list and the length of c is greater than or 
 *  equals to min, and less than or equals to max.
 */
inline bool check_form(Cell* const c, int min, int max = 0)
{
  int list_len = len(c);
  if (listp(c) && (list_len >= min) && ((!max) || (list_len <= max))) return true;
  return false;
}
// ### %adjust-array array new-dimensions element-type initial-element initial-element-p
// initial-contents initial-contents-p fill-pointer displaced-to displaced-index-offset
// => adjusted-array
Value SYS_adjust_array_internal(unsigned int numargs, Value args[])
{
  if (numargs != 10)
    return wrong_number_of_arguments(S_make_array_internal, numargs, 10, 10);

  AbstractArray * array = check_array(args[0]);
  Value dimensions = args[1];
  Value element_type = args[2];
  Value initial_element = args[3];
  Value initial_element_p = args[4];
  Value initial_contents = args[5];
  Value initial_contents_p = args[6];
  Value fill_pointer = args[7];
  Value displaced_to = args[8];
  Value displaced_index_offset = args[9];

  if (initial_element_p != NIL && initial_contents_p != NIL)
    return signal_lisp_error("ADJUST-ARRAY: cannot specify both initial element and initial contents.");

  // REVIEW the element type of multi-dimensional arrays is always T
  if (array->rank() <= 1)
    {
      if (element_type != array->element_type()
          && upgraded_array_element_type(element_type) != array->element_type())
        return signal_lisp_error("ADJUST-ARRAY: incompatible element type.");
    }

  if (array->rank() == 0)
    {
      if (initial_contents_p != NIL)
        array->aset(0, initial_contents);
      return make_value(array);
    }

  if (array->rank() == 1)
    {
      unsigned long new_size;
      if (consp(dimensions) && length(dimensions) == 1)
        new_size = check_index(xcar(dimensions));
      else
        new_size = check_index(dimensions);
      AbstractVector * v = reinterpret_cast<AbstractVector *>(array);
      AbstractVector * v2;
      if (displaced_to != NIL)
        {
          unsigned long offset;
          if (displaced_index_offset == NIL)
            offset = 0;
          else
            offset = check_index(displaced_index_offset);
          v2 = v->displace_vector(new_size, check_array(displaced_to), offset);
        }
      else
        {
          if (initial_element_p == NIL)
            {
              if (array->element_type() == S_character)
                initial_element = make_character(0);
              else
                initial_element = 0;
            }
          v2 = v->adjust_vector(new_size,
                                initial_element,
                                initial_contents);
        }
      if (fill_pointer != NIL)
        {
          if (fill_pointer == T)
            v2->set_length(v2->capacity());
          else
            v2->set_length(check_index(fill_pointer, 0, v2->capacity()));
        }
      return make_value(v2);
    }

  // rank > 1
  const unsigned int rank = listp(dimensions) ? length(dimensions) : 1;
  unsigned long * dims =
    (unsigned long *) GC_malloc_atomic(rank * sizeof(unsigned long *));
  if (listp(dimensions))
    {
      for (unsigned long i = 0; i < rank; i++)
        {
          Value dim = car(dimensions);
          dims[i] = check_index(dim);
          dimensions = xcdr(dimensions);
        }
    }
  else
      dims[0] = check_index(dimensions);
  AbstractArray * a2;
  if (displaced_to != NIL)
    {
      unsigned int offset;
      if (displaced_index_offset == NIL)
        offset = 0;
      else
        offset = check_index(displaced_index_offset);
      a2 = array->displace_array(rank, dims,
                                 check_array(displaced_to),
                                 offset);
    }
  else
    a2 = array->adjust_array(rank, dims, initial_element, initial_contents);

  return make_value(a2);
}
Exemple #30
0
String * format_to_string(Value format_control, Value format_arguments)
{
  Thread * const thread = current_thread();
  AbstractString * const control = check_string(format_control);
  assert(listp(format_arguments));
  unsigned long numargs = length(format_arguments);
  Value * args = new (GC) Value[numargs];
  for (unsigned long i = 0; i < numargs; i++)
    {
      args[i] = car(format_arguments);
      format_arguments = xcdr(format_arguments);
    }

  String * result = new String();
  unsigned long limit = control->length();
  unsigned long j = 0;
  const unsigned long NEUTRAL = 0;
  const unsigned long TILDE = 1;
  unsigned long state = NEUTRAL;

  unsigned long mincol = 0;
  char padchar = ' ';

  for (unsigned long i = 0; i < limit; i++)
    {
      char c = control->fast_char_at(i);
      if (state == NEUTRAL)
        {
          if (c == '~')
            state = TILDE;
          else
            result->append_char(c);
        }
      else if (state == TILDE)
        {
          if (c >= '0' && c <= '9')
            {
              String * token = new String();
              token->append_char(c);
              ++i;
              while (i < limit && (c = control->char_at(i)) >= '0' && c <= '9')
                {
                  token->append_char(c);
                  ++i;
                }
              // "Prefix parameters are notated as signed (sign is optional)
              // decimal numbers..."
              Value number = make_number(token, 10, NULL);
              mincol = check_index(number);

              if (c == ',')
                {
                  ++i;
                  if (i >= limit)
                    signal_lisp_error("invalid format directive");
                  c = control->char_at(i);
                  if (c == '\'')
                    {
                      ++i;
                      if (i >= limit)
                        signal_lisp_error("invalid format directive");
                      padchar = control->char_at(i);
                      ++i;
                      if (i >= limit)
                        signal_lisp_error("invalid format directive");
                      c = control->char_at(i);
                    }
                }

              // Fall through...
            }
          if (c == 'A' || c == 'a')
            {
              if (j < numargs)
                {
                  Value obj = args[j++];
                  void * last_special_binding = thread->last_special_binding();
                  thread->bind_special(S_print_escape, NIL);
                  thread->bind_special(S_print_readably, NIL);
                  result->append(write_to_string(obj));
                  thread->set_last_special_binding(last_special_binding);
                }
            }
          else if (c == 'S' || c == 's')
            {
              if (j < numargs)
                {
                  Value obj = args[j++];
                  void * last_special_binding = thread->last_special_binding();
                  thread->bind_special(S_print_escape, T);
                  result->append(write_to_string(obj));
                  thread->set_last_special_binding(last_special_binding);
                }
            }
          else if (c == 'C' || c == 'c')
            {
              if (j < numargs)
                {
                  Value obj = args[j++];
                  void * last_special_binding = thread->last_special_binding();
                  result->append(princ_to_string(obj));
                  thread->set_last_special_binding(last_special_binding);
                }
            }
          else if (c == 'D' || c == 'd')
            {
              if (j < numargs)
                {
                  Value obj = args[j++];
                  void * last_special_binding = thread->last_special_binding();
                  thread->bind_special(S_print_base, make_integer(10));
                  AbstractString * s = write_to_string(obj);
                  if (s->length() < mincol)
                    {
                      unsigned long limit = mincol - s->length();
                      for (unsigned long k = 0; k < limit; k++)
                        result->append_char(padchar);
                    }
                  result->append(s);
                  thread->set_last_special_binding(last_special_binding);
                }
            }
          else if (c == 'X' || c == 'x')
            {
              if (j < numargs)
                {
                  Value obj = args[j++];
                  void * last_special_binding = thread->last_special_binding();
                  thread->bind_special(S_print_base, make_integer(16));
                  AbstractString * s = princ_to_string(obj);
                  if (s->length() < mincol)
                    {
                      unsigned long limit = mincol - s->length();
                      for (unsigned long k = 0; k < limit; k++)
                        result->append_char(padchar);
                    }
                  result->append(s);
                  thread->set_last_special_binding(last_special_binding);
                }
            }
          else if (c == 'B' || c == 'b')
            {
              if (j < numargs)
                {
                  Value obj = args[j++];
                  void * last_special_binding = thread->last_special_binding();
                  thread->bind_special(S_print_base, FIXNUM_TWO);
                  result->append(princ_to_string(obj));
                  thread->set_last_special_binding(last_special_binding);
                }
            }
          else if (c == '%')
            {
              result->append_char('\n');
            }
          state = NEUTRAL;
        }
      else
        {
          // There are no other valid states.
          assert(false);
        }
    }
  return result;
}