static Expr* num_lte(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return TRUE;
Expr* cur = scm_car(args);
checknum(cur);
bool ok = true;
double curVal = scm_is_int(cur) ? scm_ival(cur) : scm_rval(cur);
args = scm_cdr(args);
while(scm_is_pair(args)) {
cur = scm_car(args);
checknum(cur);
double newVal = scm_is_int(cur) ? scm_ival(cur) : scm_rval(cur);
if(newVal < curVal) {
ok = false;
break;
}
curVal = newVal;
args = scm_cdr(args);
}
if(ok && args != EMPTY_LIST) return scm_mk_error("arguments to <= aren't a proper list");
return ok ? TRUE : FALSE;
}
static Expr* num_eq(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return TRUE;
Expr* cur = scm_car(args);
checknum(cur);
bool eq = true;
bool exact = scm_is_int(cur);
long long ex;
double in;
if(exact) {
ex = scm_ival(cur);
in = ex;
} else {
in = scm_rval(cur);
ex = in;
exact = ((double)ex) == in;
}
args = scm_cdr(args);
while(scm_is_pair(args)) {
cur = scm_car(args);
checknum(cur);
if(exact && scm_is_int(cur)) {
if(ex != scm_ival(cur)) {
eq = false;
break;
}
} else if(exact) {
if(in != scm_rval(cur)) {
eq = false;
break;
}
} else if(scm_is_real(cur)) {
if(in != scm_rval(cur)) {
eq = false;
break;
}
} else {
eq = false;
break;
}
args = scm_cdr(args);
}
if(eq && args != EMPTY_LIST) return scm_mk_error("arguments to = aren't a proper list");
return eq ? TRUE : FALSE;
}
static Expr* mul(Expr* args) {
assert(args);
double dbuf = 1.0;
long long lbuf = 1;
bool exact = true;
while(scm_is_pair(args)) {
Expr* cur = scm_car(args);
if(scm_is_int(cur)) {
lbuf *= scm_ival(cur);
dbuf *= scm_ival(cur);
} else if(scm_is_real(cur)) {
exact = false;
dbuf *= scm_rval(cur);
} else {
return scm_mk_error("Wrong type of argument to *");
}
args = scm_cdr(args);
}
if(args != EMPTY_LIST) {
return scm_mk_error("args to * aren't a proper list");
}
return exact ? scm_mk_int(lbuf) : scm_mk_real(dbuf);
}
static Expr* sub(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return scm_mk_error("no arguments passed to - (expected at least 1)");
// unary case
if(scm_cdr(args) == EMPTY_LIST) {
Expr* v = scm_car(args);
if(scm_is_int(v)) return scm_mk_int(-scm_ival(v));
if(scm_is_real(v)) return scm_mk_int(-scm_rval(v));
return scm_mk_error("wrong type of argument to -");
}
Expr* first = scm_car(args);
if(!scm_is_num(first)) return scm_mk_error("wrong type of argument to -");
bool exact = scm_is_int(first);
double dbuf = exact ? scm_ival(first) : scm_rval(first);
long long lbuf = exact ? scm_ival(first) : 0;
args = scm_cdr(args);
while(scm_is_pair(args)) {
Expr* cur = scm_car(args);
if(scm_is_int(cur)) {
lbuf -= scm_ival(cur);
dbuf -= scm_ival(cur);
} else if(scm_is_real(cur)) {
exact = false;
dbuf -= scm_rval(cur);
} else {
return scm_mk_error("Wrong type of argument to +");
}
args = scm_cdr(args);
}
if(args != EMPTY_LIST) {
return scm_mk_error("args to + aren't a proper list");
}
return exact ? scm_mk_int(lbuf) : scm_mk_real(dbuf);
}
static Expr* integer(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return scm_mk_error("No args passed to integer? (expected 1)");
Expr* fst = scm_car(args);
Expr* rst = scm_cdr(args);
if(rst != EMPTY_LIST) return scm_mk_error("Too many args passed to integer? (expected 1)");
return scm_is_int(fst) ? TRUE : FALSE;
}
static Expr* exact(Expr* args) {
assert(args);
if(args == EMPTY_LIST) return scm_mk_error("No args passed to exact? (expected 1)");
Expr* fst = scm_car(args);
Expr* rst = scm_cdr(args);
if(rst != EMPTY_LIST) return scm_mk_error("Too many args passed to exact? (expected 1)");
if(number(args) != TRUE) return scm_mk_error("Argument to exact? is not a number");
return scm_is_int(fst) ? TRUE : FALSE;
}
static Expr* ex2in(Expr* args) {
assert(args);
if(scm_list_len(args) != 1) return scm_mk_error("exact->inexact expects 1 arg");
Expr* fst = scm_car(args);
if(scm_is_int(fst)) {
Expr* toRet = scm_mk_real(scm_ival(fst));
return toRet ? toRet : OOM;
} else if(scm_is_real(fst)) {
return fst;
} else {
return scm_mk_error("exact->inexact expects a number");
}
}
static Expr* int2chr(Expr* args) {
assert(args);
if(scm_list_len(args) != 1) return scm_mk_error("integer->char expects 1 arg");
Expr* fst = scm_car(args);
if(!scm_is_int(fst)) return scm_mk_error("integer->char expects an integer");
long long v = scm_ival(fst);
if(!(0 <= v && v < 256)) return scm_mk_error("argument to integer->char is out of range");
return scm_mk_char((char)v);
}
static Expr* str_ref(Expr* args) {
assert(args);
if(scm_list_len(args) != 2) return scm_mk_error("string-ref expects 2 args");
Expr* a = scm_car(args);
if(!scm_is_string(a)) return scm_mk_error("string-ref expects a string as its 1st arg");
Expr* i = scm_cadr(args);
if(!scm_is_int(i)) return scm_mk_error("string-ref expects an int as its 2nd arg");
Expr* toRet = scm_mk_char(scm_sval(a)[scm_ival(i)]);
return toRet ? toRet : OOM;
}
static Expr* mk_str(Expr* args) {
assert(args);
int len = scm_list_len(args);
if(len < 0 || len > 2) return scm_mk_error("make-string expects 1 or 2 args");
Expr* l = scm_car(args);
if(!scm_is_int(l)) return scm_mk_error("make-string expects an int as its 1st arg");
long long size = scm_ival(l);
char* buf = malloc(size+1);
if(!buf) return OOM;
Expr* toRet = scm_alloc();
if(!toRet) {
free(buf);
return OOM;
}
char c = 'a';
if(len == 2) {
Expr* ca = scm_cadr(args);
if(!scm_is_char(ca)) {
free(buf);
return scm_mk_error("make-string expects a char as its 2nd arg");
}
c = scm_cval(ca);
}
memset(buf, c, size);
buf[size] = '\0';
toRet->tag = ATOM;
toRet->atom.type = STRING;
toRet->atom.sval = buf;
return toRet;
}
static Expr* str_set(Expr* args) {
assert(args);
if(scm_list_len(args) != 3) return scm_mk_error("string-set! expects 2 args");
Expr* a = scm_car(args);
if(!scm_is_string(a)) return scm_mk_error("string-set! expects a string as its 1st arg");
Expr* i = scm_cadr(args);
if(!scm_is_int(i)) return scm_mk_error("string-set! expects an int as its 2nd arg");
Expr* c = scm_caddr(args);
if(!scm_is_char(c)) return scm_mk_error("string-set! expects a char as its 3rd arg");
scm_sval(a)[scm_ival(i)] = scm_cval(c);
return EMPTY_LIST;
}
inline bool tmscm_is_int (tmscm obj) { return scm_is_int (obj); }
