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);
}
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);
}
/* 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);
}
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));
}
}
/* 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;
}
//--------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);
}
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;
}
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
}
/* 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));
}
}
/* 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);
}
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));
}
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;
}
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()");
}
/*
* 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;
}
std::string sprint(const cons_t* p)
{
std::string s;
return sprint(listp(p) ? cons(p) : p, s, true);
}
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");
}
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;
}
int f_listp(int arglist){
if(listp(car(arglist)))
return(makeT());
else
return(makeNIL());
}
/**
* \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");
}
}
}
int f_listp(int arglist){
if(listp(car(arglist)))
return(T);
else
return(NIL);
}
/**
* \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);
}
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;
}