void variant::throw_type_error(variant::TYPE t) const
{
throw type_error(formatter() << "type error: " << " expected " << variant_type_to_string(t) << " but found " << variant_type_to_string(type_) << " (" << to_debug_string() << ")");
}
inline entry::string_type const& entry::string() const
{
if (m_type != string_t) throw type_error("invalid type requested from entry");
return *reinterpret_cast<const string_type*>(data);
}
inline typename basic_val<T>::const_iterator basic_val<T>::end() const
{
if (!is_array(*this))
throw type_error("basic_val is not an array");
return std::end(a_);
}
//note: this function should NOT overwrite str, but append text to it!
virtual void serialize_to_string(std::string& /*str*/) const {
throw type_error("Tried to serialize type which cannot be serialized");
}
DEFINEFN
bool PsycoObject_SetItem(PsycoObject* po, vinfo_t* o, vinfo_t* key,
vinfo_t* value)
{
PyMappingMethods *m;
PyTypeObject* tp = Psyco_NeedType(po, o);
if (tp == NULL)
return false;
m = tp->tp_as_mapping;
if (m && m->mp_ass_subscript) {
char* vargs = (value!=NULL) ? "vvv" : "vvl";
return Psyco_META3(po, m->mp_ass_subscript,
CfNoReturnValue|CfPyErrIfNonNull,
vargs, o, key, value) != NULL;
}
if (tp->tp_as_sequence) {
/* TypeSwitch */
PyTypeObject* ktp = Psyco_NeedType(po, key);
if (ktp == NULL)
return false;
if (PyType_TypeCheck(ktp, &PyInt_Type)) {
return PsycoSequence_SetItem(po, o,
PsycoInt_AS_LONG(po, key),
value);
}
if (PyType_TypeCheck(ktp, &PyLong_Type)) {
bool result;
vinfo_t* key_value = PsycoLong_AsLong(po, key);
if (key_value == NULL)
return false;
result = PsycoSequence_SetItem(po, o, key_value,value);
vinfo_decref(key_value, po);
return result;
}
#if HAVE_NB_INDEX
if (PsycoIndex_Check(ktp)) {
bool result;
vinfo_t* key_value;
key_value = psyco_generic_call(po, PyNumber_AsSsize_t,
CfReturnNormal|CfPyErrCheckMinus1,
"vl", key, (long) PyExc_IndexError);
if (key_value == NULL)
return false;
result = PsycoSequence_SetItem(po, o, key_value,value);
vinfo_decref(key_value, po);
return result;
}
#endif
if (tp->tp_as_sequence->sq_ass_item) {
type_error(po, "sequence index must be integer");
return false;
}
}
type_error(po, (value!=NULL) ?
"object does not support item assignment" :
"object does not support item deletion");
return false;
}
LUALIB_API long luaL_check_number (lua_State *L, int narg) {
long d = lua_tonumber(L, narg);
if (d == 0 && !lua_isnumber(L, narg)) /* avoid extra test when d is not 0 */
type_error(L, narg, LUA_TNUMBER);
return d;
}
static foreign_t
turtle_read_string(term_t C0, term_t Stream, term_t C, term_t Value)
{ int c;
charbuf b;
IOSTREAM *in;
int endlen = 1;
if ( !PL_get_integer(C0, &c) )
return type_error(C0, "code");
if ( c != '"' )
return FALSE;
if ( !PL_get_stream_handle(Stream, &in) )
return FALSE;
init_charbuf(&b);
c = Sgetcode(in);
if ( c == '"' )
{ c = Sgetcode(in);
if ( c == '"' ) /* """...""" */
{ endlen = 3;
c = Sgetcode(in);
} else
{ PL_release_stream(in);
return (PL_unify_integer(C, c) &&
PL_unify_atom(Value, ATOM_));
}
}
for(;;c = Sgetcode(in))
{ if ( c == -1 )
{ free_charbuf(&b);
PL_release_stream(in);
return syntax_error("eof_in_string", in);
} else if ( c == '"' )
{ int count = 1;
for(count=1; count<endlen; )
{ if ( (c=Sgetcode(in)) == '"' )
count++;
else
break;
}
if ( count == endlen )
{ int rc;
c = Sgetcode(in);
rc = (PL_unify_integer(C, c) &&
PL_unify_wchars(Value, PL_ATOM, b.here-b.base, b.base));
free_charbuf(&b);
PL_release_stream(in);
return rc;
}
while(count-- > 0)
add_charbuf(&b, '"');
add_charbuf(&b, c);
} else if ( c == '\\' )
{ int esc;
c = Sgetcode(in);
if ( !string_escape(in, c, &esc) )
{ free_charbuf(&b);
PL_release_stream(in);
return FALSE;
}
add_charbuf(&b, esc);
} else
{ add_charbuf(&b, c);
}
}
}
data_type_t typecheck_expression(node_t* root)
{
if(outputStage == 10)
fprintf( stderr, "Type checking expression %s\n", root->expression_type.text);
switch (root->expression_type.index) {
case ADD_E:
case SUB_E:
case MUL_E:
case DIV_E:
{
data_type_t type1 = root->children[0]->typecheck(root->children[0]);
data_type_t type2 = root->children[1]->typecheck(root->children[1]);
if (type1.base_type == INT_TYPE && type2.base_type == INT_TYPE) {
return wrap_base_type(INT_TYPE);
}
if (type1.base_type == FLOAT_TYPE && type2.base_type == FLOAT_TYPE) {
return wrap_base_type(FLOAT_TYPE);
}
type_error(root);
}
break;
case LESS_E:
case GREATER_E:
case GEQUAL_E:
case LEQUAL_E:
{
data_type_t type1 = root->children[0]->typecheck(root->children[0]);
data_type_t type2 = root->children[1]->typecheck(root->children[1]);
if (type1.base_type == INT_TYPE && type2.base_type == INT_TYPE) {
return wrap_base_type(BOOL_TYPE);
}
if (type1.base_type == FLOAT_TYPE && type2.base_type == FLOAT_TYPE) {
return wrap_base_type(BOOL_TYPE);
}
type_error(root);
}
break;
case EQUAL_E:
case NEQUAL_E:
{
data_type_t type1 = root->children[0]->typecheck(root->children[0]);
data_type_t type2 = root->children[1]->typecheck(root->children[1]);
if (type1.base_type == INT_TYPE && type2.base_type == INT_TYPE) {
return wrap_base_type(BOOL_TYPE);
}
if (type1.base_type == FLOAT_TYPE && type2.base_type == FLOAT_TYPE) {
return wrap_base_type(BOOL_TYPE);
}
if (type1.base_type == BOOL_TYPE && type2.base_type == BOOL_TYPE) {
return wrap_base_type(BOOL_TYPE);
}
type_error(root);
}
break;
case UMINUS_E:
{
data_type_t type = root->children[0]->typecheck(root->children[0]);
if (type.base_type == INT_TYPE || type.base_type == FLOAT_TYPE) {
return type;
}
type_error(root);
}
break;
case NOT_E:
{
data_type_t type = root->children[0]->typecheck(root->children[0]);
if (type.base_type == BOOL_TYPE) {
return type;
}
type_error(root);
}
break;
case AND_E:
case OR_E:
{
data_type_t type1 = root->children[0]->typecheck(root->children[0]);
data_type_t type2 = root->children[1]->typecheck(root->children[1]);
if (type1.base_type == BOOL_TYPE && type2.base_type == BOOL_TYPE) {
return wrap_base_type(BOOL_TYPE);
}
type_error(root);
}
break;
default:
typecheck_children(root);
return root->data_type;
}
}
bool config::contain(const std::string& key) const {
if (type() != pfi::text::json::json::Object)
throw JUBATUS_EXCEPTION(type_error(path_, pfi::text::json::json::Object, type()));
return json_.count(key) > 0;
}
int check_expr (tree t) {
int typeL, typeR, typeI;
if (t == NULL) {
fprintf (stderr, "Shouldn't be here: missing expression\n");
return NoType;
}
switch (t->kind) { // switch for expr type-checking
case Plus: case Minus: case Star: case Slash: case Mod:
// arithmetic operators are Integers and return Integer
typeL = check_expr (t->first);
if (t->second != NULL) { // binary operator
typeR = check_expr (t->first);
if (typeL == Integer && typeR == Integer) {
return Integer;
} else {
type_error(t->kind);
return NoType;
}
} else { // unary operator, only plus/minus
if (typeL == Integer && t->kind == Plus || t->kind == Minus) {
return Integer;
} else {
type_error(t->kind);
return NoType;
}
}
break;
case Equal: case DivEq:
case Less: case LessEq:
case Greater: case GreaterEq:
// relational operators must agree, result bool
typeL = check_expr (t->first);
typeR = check_expr (t->second);
if (typeL == typeR && typeL == Integer || typeL == Boolean) {
return Boolean;
} else {
type_error(t->kind);
return NoType;
}
break;
case Or: case And: case Xor: case Not:
// operands for above must be boolean and result boolean
typeL = check_expr (t->first);
typeR = check_expr (t->second);
if (typeL == Boolean && typeR == Boolean) {
return Boolean;
} else {
type_error(t->kind);
return NoType;
}
break;
case IntConst:
return Integer;
case Boolean:
return Boolean;
case True: case False:
return Boolean;
case Ident:
// ST lookup
if ( ST[t->value]->valid == false || ST[t->value]->scope > scope) {
fprintf(stderr, "Entry %d-%s invalid in ST:%d\n", t->value, id_name (t->value), scope);
error_num++;
return NoType;
} else {
return ST[t->value]->type;
}
case LBrac: // Ident[index]
// check that index is type Integer
typeI = check_expr(t->second);
if ( typeI != Integer) {
type_error(t->kind);
return NoType;
} else {
// ST lookup
if ( ST[t->first->value]->valid == false || ST[t->first->value]->type != Array ||
ST[t->first->value]->scope > scope) {
fprintf(stderr, "Entry %d-%s invalid in ST:%d or not an Array\n", t->value, id_name (t->value), scope);
error_num++;
return NoType;
} else {
return ST[t->first->value]->arrayBaseT;
}
}
break;
default:
fprintf (stderr, "You shouldn't be here; invalid expression operator %d %s\n",
t->kind, tokName[t->kind]);
} // end switch(t->kind)
} // end check_expr()
inline void type_assert(lua_State* L, int index, type expected) {
int actual = lua_type(L, index);
if(expected != type::poly && static_cast<int>(expected) != actual) {
type_error(L, static_cast<int>(expected), actual);
}
}
void check_stmts (tree t) {
int typeL, typeR, t_start, t_end;
for (; t != NULL; t = t->next) {
switch (t->kind) {
case Procedure:
enterScope();
fprintf (stderr, "Procedure: scope++ : %d\n", scope);
handle_decls (t->second);
check_stmts (t->third);
printST();
exitScope();
fprintf (stderr, "Procedure: scope-- : %d\n", scope);
break;
case Assign:
if ( t->first->kind != LBrac) { // non-array assignment
// ST lookup
if ( ST[t->first->value]->valid && ST[t->first->value]->scope <= scope) { // entry in ST
typeL = ST[t->first->value]->type;
typeR = check_expr(t->second);
} else { // no visible entry in ST
fprintf(stderr, "Entry %d-%s invalid in ST:%d\n", t->first->value, id_name (t->first->value), scope);
error_num++;
return;
}
} else if (t->first->kind == LBrac) { // array assignment
// ST array lookup
if ( ST[t->first->first->value]->valid && ST[t->first->first->value]->type == Array &&
ST[t->first->first->value]->scope <= scope) { // entry in ST
typeL = check_expr (t->first);
typeR = check_expr (t->second);
} else { // no visible entry in ST
fprintf(stderr, "Entry %d-%s invalid in ST:%d\n",
t->first->first->value, id_name (t->first->first->value), scope);
error_num++;
return;
}
}
if (typeL != typeR) { // LHS and RHS of assignment must match
type_error(t->kind);
return;
}
break;
case If: case Elsif:
// expr in If must be Boolean
if (check_expr(t->first) != Boolean) {
type_error(t->kind);
return;
}
check_stmts(t->second);
check_stmts(t->third);
break;
case Else:
check_stmts(t->first);
break;
case For:
// starts a new scope
enterScope();
fprintf (stderr, "For: scope++ : %d\n", scope);
// 2 range values must be same type
t_start = check_expr(t->second->first);
t_end = check_expr(t->second->second);
if ( t_start != t_end || t_start == NoType) {
type_error(t->kind);
return;
} else {
// add Ident to ST w/ type of t_start in a new scope
int pos = t->first->value; // Ident in For loop
if ( ST[pos]->valid == true) {
push (ST[pos]); // push prev scope entry to stack
}
ST[pos]->index = pos;
ST[pos]->type = t_start;
ST[pos]->scope = scope; // will be scope not 2
char *tmp = id_name(pos);
ST[pos]->name = tmp;
ST[pos]->valid = true;
ST[pos]->typeSize = -1;
ST[pos]->addr = -1;
}
check_stmts(t->third); // body of For loop
printST();
exitScope();
fprintf (stderr, "For: scope-- : %d\n", scope);
break;
// Exit without bool_expr handled in for loop b/c tree will be NULL
case Exit:
typeL = check_expr(t->first);
if ( typeL != Boolean || typeL == NoType) {
type_error( t->kind);
}
break;
case Declare:
// starts a new scope
enterScope();
fprintf (stderr, "Declare: scope++ : %d\n", scope);
handle_decls (t->first);
check_stmts (t->second);
printST();
exitScope();
fprintf (stderr, "Declare: scope-- : %d\n", scope);
break;
default:
fprintf(stderr, "No stmt match for token %d\n", t->kind);
// endScope()
} // end switch statement
} // end for loop
} // end check_stmts()
inline entry::dictionary_type const& entry::dict() const
{
if (m_type != dictionary_t) throw type_error("invalid type requested from entry");
return *reinterpret_cast<const dictionary_type*>(data);
}
inline entry::list_type& entry::list()
{
if (m_type != list_t) throw type_error("invalid type requested from entry");
return *reinterpret_cast<list_type*>(data);
}
LUALIB_API void luaL_checktype(lua_State *L, int narg, int t) {
if (lua_type(L, narg) != t)
type_error(L, narg, t);
}
void Element::type_check() const
{
if (!check_convert<T>())
throw type_error (m_type, to_string<T>());
}
LUALIB_API const char *luaL_check_lstr (lua_State *L, int narg, size_t *len) {
const char *s = lua_tostring(L, narg);
if (!s) type_error(L, narg, LUA_TSTRING);
if (len) *len = lua_strlen(L, narg);
return s;
}
static type_error create(int id_, const std::string& what_arg)
{
std::string w = exception::name("type_error", id_) + what_arg;
return type_error(id_, w.c_str());
}
static foreign_t
cgi_property(term_t cgi, term_t prop)
{ IOSTREAM *s;
cgi_context *ctx;
term_t arg = PL_new_term_ref();
atom_t name;
int arity;
int rc = TRUE;
if ( !get_cgi_stream(cgi, &s, &ctx) )
return FALSE;
if ( !PL_get_name_arity(prop, &name, &arity) || arity != 1 )
{ rc = type_error(prop, "cgi_property");
goto out;
}
_PL_get_arg(1, prop, arg);
if ( name == ATOM_request )
{ if ( ctx->request )
rc = unify_record(arg, ctx->request);
else
rc = PL_unify_nil(arg);
} else if ( name == ATOM_header )
{ if ( ctx->header )
rc = unify_record(arg, ctx->header);
else
rc = PL_unify_nil(arg);
} else if ( name == ATOM_id )
{ rc = PL_unify_int64(arg, ctx->id);
} else if ( name == ATOM_client )
{ rc = PL_unify_stream(arg, ctx->stream);
} else if ( name == ATOM_transfer_encoding )
{ rc = PL_unify_atom(arg, ctx->transfer_encoding);
} else if ( name == ATOM_connection )
{ rc = PL_unify_atom(arg, ctx->connection ? ctx->connection : ATOM_close);
} else if ( name == ATOM_content_length )
{ if ( ctx->transfer_encoding == ATOM_chunked )
rc = PL_unify_int64(arg, ctx->chunked_written);
else
rc = PL_unify_int64(arg, ctx->datasize - ctx->data_offset);
} else if ( name == ATOM_header_codes )
{ if ( ctx->data_offset > 0 )
rc = PL_unify_chars(arg, PL_CODE_LIST, ctx->data_offset, ctx->data);
else /* incomplete header */
rc = PL_unify_chars(arg, PL_CODE_LIST, ctx->datasize, ctx->data);
} else if ( name == ATOM_state )
{ atom_t state;
switch(ctx->state)
{ case CGI_HDR: state = ATOM_header; break;
case CGI_DATA: state = ATOM_data; break;
case CGI_DISCARDED: state = ATOM_discarded; break;
default:
assert(0);
}
rc = PL_unify_atom(arg, state);
} else
{ rc = existence_error(prop, "cgi_property");
}
out:
if ( !PL_release_stream(s) )
{ if ( PL_exception(0) )
PL_clear_exception();
}
return rc;
}
inline basic_val<T> const& basic_val<T>::operator[](string_t const& s) const
{
if (!is_object(*this))
throw type_error("basic_val is not an object");
return internal::access<self_t const, internal::subscript_tag>::sub(*this, s);
}
inline void type_error(lua_State* L, type expected, type actual) {
type_error(L, static_cast<int>(expected), static_cast<int>(actual));
}
inline basic_val<T>::operator typename basic_val<T>::char_t const*() const
{
if (!is_string(*this))
throw type_error("basic_val is not a string");
return s_.c_str();
}
value_t eval_sexpr(value_t e, value_t *penv)
{
value_t f, v, bind, headsym, asym, labl=0, *pv, *argsyms, *body, *lenv;
value_t *rest;
cons_t *c;
symbol_t *sym;
u_int32_t saveSP;
int i, nargs, noeval=0;
number_t s, n;
eval_top:
if (issymbol(e)) {
sym = (symbol_t*)ptr(e);
if (sym->constant != UNBOUND) return sym->constant;
v = *penv;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == e)
return cdr_(bind);
v = cdr_(v);
}
if ((v = sym->binding) == UNBOUND)
lerror("eval: error: variable %s has no value\n", sym->name);
return v;
}
if ((unsigned)(char*)&nargs < (unsigned)stack_bottom || SP>=(N_STACK-100))
lerror("eval: error: stack overflow\n");
saveSP = SP;
PUSH(e);
PUSH(*penv);
f = eval(car_(e), penv);
*penv = Stack[saveSP+1];
if (isbuiltin(f)) {
// handle builtin function
if (!isspecial(f)) {
// evaluate argument list, placing arguments on stack
v = Stack[saveSP] = cdr_(Stack[saveSP]);
while (iscons(v)) {
v = eval(car_(v), penv);
*penv = Stack[saveSP+1];
PUSH(v);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
}
apply_builtin:
nargs = SP - saveSP - 2;
switch (intval(f)) {
// special forms
case F_QUOTE:
v = cdr_(Stack[saveSP]);
if (!iscons(v))
lerror("quote: error: expected argument\n");
v = car_(v);
break;
case F_MACRO:
case F_LAMBDA:
v = Stack[saveSP];
if (*penv != NIL) {
// build a closure (lambda args body . env)
v = cdr_(v);
PUSH(car(v));
argsyms = &Stack[SP-1];
PUSH(car(cdr_(v)));
body = &Stack[SP-1];
v = cons_(intval(f)==F_LAMBDA ? &LAMBDA : &MACRO,
cons(argsyms, cons(body, penv)));
}
break;
case F_LABEL:
v = Stack[saveSP];
if (*penv != NIL) {
v = cdr_(v);
PUSH(car(v)); // name
pv = &Stack[SP-1];
PUSH(car(cdr_(v))); // function
body = &Stack[SP-1];
*body = eval(*body, penv); // evaluate lambda
v = cons_(&LABEL, cons(pv, cons(body, &NIL)));
}
break;
case F_IF:
v = car(cdr_(Stack[saveSP]));
if (eval(v, penv) != NIL)
v = car(cdr_(cdr_(Stack[saveSP])));
else
v = car(cdr(cdr_(cdr_(Stack[saveSP]))));
tail_eval(v, Stack[saveSP+1]);
break;
case F_COND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = NIL;
while (iscons(*pv)) {
c = tocons(car_(*pv), "cond");
v = eval(c->car, penv);
*penv = Stack[saveSP+1];
if (v != NIL) {
*pv = cdr_(car_(*pv));
// evaluate body forms
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv), penv);
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
}
*pv = cdr_(*pv);
}
break;
case F_AND:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = T;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv), penv)) == NIL) {
SP = saveSP;
return NIL;
}
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
case F_OR:
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
if ((v=eval(car_(*pv), penv)) != NIL) {
SP = saveSP;
return v;
}
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
case F_WHILE:
PUSH(cdr(cdr_(Stack[saveSP])));
body = &Stack[SP-1];
PUSH(*body);
Stack[saveSP] = car_(cdr_(Stack[saveSP]));
value_t *cond = &Stack[saveSP];
PUSH(NIL);
pv = &Stack[SP-1];
while (eval(*cond, penv) != NIL) {
*penv = Stack[saveSP+1];
*body = Stack[SP-2];
while (iscons(*body)) {
*pv = eval(car_(*body), penv);
*penv = Stack[saveSP+1];
*body = cdr_(*body);
}
}
v = *pv;
break;
case F_PROGN:
// return last arg
Stack[saveSP] = cdr_(Stack[saveSP]);
pv = &Stack[saveSP];
v = NIL;
if (iscons(*pv)) {
while (iscons(cdr_(*pv))) {
v = eval(car_(*pv), penv);
*penv = Stack[saveSP+1];
*pv = cdr_(*pv);
}
tail_eval(car_(*pv), *penv);
}
break;
// ordinary functions
case F_SET:
argcount("set", nargs, 2);
e = Stack[SP-2];
v = *penv;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == e) {
cdr_(bind) = (v=Stack[SP-1]);
SP=saveSP;
return v;
}
v = cdr_(v);
}
tosymbol(e, "set")->binding = (v=Stack[SP-1]);
break;
case F_BOUNDP:
argcount("boundp", nargs, 1);
sym = tosymbol(Stack[SP-1], "boundp");
if (sym->binding == UNBOUND && sym->constant == UNBOUND)
v = NIL;
else
v = T;
break;
case F_EQ:
argcount("eq", nargs, 2);
v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
break;
case F_CONS:
argcount("cons", nargs, 2);
v = mk_cons();
car_(v) = Stack[SP-2];
cdr_(v) = Stack[SP-1];
break;
case F_CAR:
argcount("car", nargs, 1);
v = car(Stack[SP-1]);
break;
case F_CDR:
argcount("cdr", nargs, 1);
v = cdr(Stack[SP-1]);
break;
case F_RPLACA:
argcount("rplaca", nargs, 2);
car(v=Stack[SP-2]) = Stack[SP-1];
break;
case F_RPLACD:
argcount("rplacd", nargs, 2);
cdr(v=Stack[SP-2]) = Stack[SP-1];
break;
case F_ATOM:
argcount("atom", nargs, 1);
v = ((!iscons(Stack[SP-1])) ? T : NIL);
break;
case F_SYMBOLP:
argcount("symbolp", nargs, 1);
v = ((issymbol(Stack[SP-1])) ? T : NIL);
break;
case F_NUMBERP:
argcount("numberp", nargs, 1);
v = ((isnumber(Stack[SP-1])) ? T : NIL);
break;
case F_ADD:
s = 0;
for (i=saveSP+2; i < (int)SP; i++) {
n = tonumber(Stack[i], "+");
s += n;
}
v = number(s);
break;
case F_SUB:
if (nargs < 1)
lerror("-: error: too few arguments\n");
i = saveSP+2;
s = (nargs==1) ? 0 : tonumber(Stack[i++], "-");
for (; i < (int)SP; i++) {
n = tonumber(Stack[i], "-");
s -= n;
}
v = number(s);
break;
case F_MUL:
s = 1;
for (i=saveSP+2; i < (int)SP; i++) {
n = tonumber(Stack[i], "*");
s *= n;
}
v = number(s);
break;
case F_DIV:
if (nargs < 1)
lerror("/: error: too few arguments\n");
i = saveSP+2;
s = (nargs==1) ? 1 : tonumber(Stack[i++], "/");
for (; i < (int)SP; i++) {
n = tonumber(Stack[i], "/");
if (n == 0)
lerror("/: error: division by zero\n");
s /= n;
}
v = number(s);
break;
case F_LT:
argcount("<", nargs, 2);
if (tonumber(Stack[SP-2],"<") < tonumber(Stack[SP-1],"<"))
v = T;
else
v = NIL;
break;
case F_NOT:
argcount("not", nargs, 1);
v = ((Stack[SP-1] == NIL) ? T : NIL);
break;
case F_EVAL:
argcount("eval", nargs, 1);
v = Stack[SP-1];
tail_eval(v, NIL);
break;
case F_PRINT:
for (i=saveSP+2; i < (int)SP; i++)
print(stdout, v=Stack[i]);
break;
case F_READ:
argcount("read", nargs, 0);
v = read_sexpr(stdin);
break;
case F_LOAD:
argcount("load", nargs, 1);
v = load_file(tosymbol(Stack[SP-1], "load")->name);
break;
case F_PROG1:
// return first arg
if (nargs < 1)
lerror("prog1: error: too few arguments\n");
v = Stack[saveSP+2];
break;
case F_APPLY:
argcount("apply", nargs, 2);
v = Stack[saveSP] = Stack[SP-1]; // second arg is new arglist
f = Stack[SP-2]; // first arg is new function
POPN(2); // pop apply's args
if (isbuiltin(f)) {
if (isspecial(f))
lerror("apply: error: cannot apply special operator "
"%s\n", builtin_names[intval(f)]);
// unpack arglist onto the stack
while (iscons(v)) {
PUSH(car_(v));
v = cdr_(v);
}
goto apply_builtin;
}
noeval = 1;
goto apply_lambda;
}
SP = saveSP;
return v;
}
else {
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
apply_lambda:
if (iscons(f)) {
headsym = car_(f);
if (headsym == LABEL) {
// (label name (lambda ...)) behaves the same as the lambda
// alone, except with name bound to the whole label expression
labl = f;
f = car(cdr(cdr_(labl)));
headsym = car(f);
}
// apply lambda or macro expression
PUSH(cdr(cdr(cdr_(f))));
lenv = &Stack[SP-1];
PUSH(car_(cdr_(f)));
argsyms = &Stack[SP-1];
PUSH(car_(cdr_(cdr_(f))));
body = &Stack[SP-1];
if (labl) {
// add label binding to environment
PUSH(labl);
PUSH(car_(cdr_(labl)));
*lenv = cons_(cons(&Stack[SP-1], &Stack[SP-2]), lenv);
POPN(3);
v = Stack[saveSP]; // refetch arglist
}
if (headsym == MACRO)
noeval = 1;
else if (headsym != LAMBDA)
lerror("apply: error: head must be lambda, macro, or label\n");
// build a calling environment for the lambda
// the environment is the argument binds on top of the captured
// environment
while (iscons(v)) {
// bind args
if (!iscons(*argsyms)) {
if (*argsyms == NIL)
lerror("apply: error: too many arguments\n");
break;
}
asym = car_(*argsyms);
if (!issymbol(asym))
lerror("apply: error: formal argument not a symbol\n");
v = car_(v);
if (!noeval) {
v = eval(v, penv);
*penv = Stack[saveSP+1];
}
PUSH(v);
*lenv = cons_(cons(&asym, &Stack[SP-1]), lenv);
POPN(2);
*argsyms = cdr_(*argsyms);
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
if (*argsyms != NIL) {
if (issymbol(*argsyms)) {
if (noeval) {
*lenv = cons_(cons(argsyms, &Stack[saveSP]), lenv);
}
else {
PUSH(NIL);
PUSH(NIL);
rest = &Stack[SP-1];
// build list of rest arguments
// we have to build it forwards, which is tricky
while (iscons(v)) {
v = eval(car_(v), penv);
*penv = Stack[saveSP+1];
PUSH(v);
v = cons_(&Stack[SP-1], &NIL);
POP();
if (iscons(*rest))
cdr_(*rest) = v;
else
Stack[SP-2] = v;
*rest = v;
v = Stack[saveSP] = cdr_(Stack[saveSP]);
}
*lenv = cons_(cons(argsyms, &Stack[SP-2]), lenv);
}
}
else if (iscons(*argsyms)) {
lerror("apply: error: too few arguments\n");
}
}
noeval = 0;
// macro: evaluate expansion in the calling environment
if (headsym == MACRO) {
SP = saveSP;
PUSH(*lenv);
lenv = &Stack[SP-1];
v = eval(*body, lenv);
tail_eval(v, *penv);
}
else {
tail_eval(*body, *lenv);
}
// not reached
}
type_error("apply", "function", f);
return NIL;
}
inline typename basic_val<T>::iterator basic_val<T>::begin()
{
if (!is_array(*this))
throw type_error("basic_val is not an array");
return std::begin(a_);
}
//!
//! \brief static conversion function
//!
//! This implementation does nothing else than throwing a type
//! error exception.
//!
//! \throws type_error types cannot be converted
//! \return nothing
//!
static target_type convert(const source_type &)
{
throw type_error(EXCEPTION_RECORD,"Conversion not possible!");
return target_type();
}
inline entry::integer_type const& entry::integer() const
{
if (m_type != int_t) throw type_error("invalid type requested from entry");
return *reinterpret_cast<const integer_type*>(data);
}
