//--------eval---------------
int eval(int addr){
int res;
if(atomp(addr)){
if(numberp(addr))
return(addr);
if(symbolp(addr)){
res = findsym(addr);
if(res == -1)
error(CANT_FIND_ERR, "eval", addr);
else
return(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(functionp(car(addr)))
return(apply(car(addr),evlis(cdr(addr))));
}
error(CANT_FIND_ERR, "eval", addr);
return(0);
}
int equalp(int x1, int x2){
int start1,start2,len1,len2,elt;
if(nullp(x1) && nullp(x2))
return(1);
if((nullp(x1) && !nullp(x2)) || (!nullp(x1) && nullp(x2)))
return(0);
if(numberp(x1) && numberp(x2) && numeqp(x1,x2))
return(1);
if(vectorp(x1) && vectorp(x2)){
start1 = car(x1); start2 = car(x2);
len1 = cdr(x1); len2 = cdr(x2);
if(len1 == len2){
if(len1 == 0)
return(1);
else{
elt = 0;
while(elt < len1){
if(!equalp(car(start1+elt),car(start2+elt)))
return(0);
elt++;
}
}
return(1);
}
else
return(0);
}
if(atomp(x1) && atomp(x2))
return(eqvp(x1,x2));
if(equalp(car(x1),car(x2)))
return(equalp(cdr(x1),cdr(x2)));
else
return(0);
}
int eqp(int addr1, int addr2){
if((numberp(addr1)) && (numberp(addr2))
&& ((GET_NUMBER(addr1)) == (GET_NUMBER(addr2))))
return(1);
else if ((symbolp(addr1)) && (symbolp(addr2))
&& (SAME_NAME(addr1,addr2)))
return(1);
else
return(0);
}
LISPTR lisp_print(LISPTR x, FILE* out)
{
if (consp(x)) {
fputwc('(', out);
while (true) {
lisp_print(car(x), out);
x = cdr(x);
if (!consp(x)) {
if (x != NIL) {
fputws(L" . ", out);
lisp_print(x, out);
}
break;
}
fputwc(' ', out);
}
fputwc(')', out);
} else if (symbolp(x)) {
fputws(string_text(symbol_name(x)), out);
} else if (numberp(x)) {
fwprintf(out, L"%g", number_value(x));
} else if (stringp(x)) {
fputwc('"', out);
fputws(string_text(x), out);
fputwc('"', out);
} else {
fputws(L"*UNKOBJ*", out);
}
return x;
}
int atomp(int x){
if(numberp(x) || symbolp(x) || charp(x) || stringp(x) || booleanp(x) || identifierp(x)
|| IS_SYNCLO(x))
return(1);
else
return(0);
}
void read_cmnd_line(int argc, char *argv[], double pb[]) {
int i, j;
double x;
int valid;
for (i = 1; i < argc; i++) {
for (j = 0; j < NParams; j++)
if (strcmp(argv[i],ParamTable[j].cmnd) == 0) {
i = i+1;
valid = 1;
if (!numberp(argv[i]))
valid = 0;
else {
x = atof(argv[i]);
if ((x < ParamTable[j].min) || (x > ParamTable[j].max))
valid = 0;
}
break;
}
if (j < NParams)
if (valid)
pb[ParamTable[j].key] = x;
else
cerr << "Bad parameter value: " << argv[i-1] << ", " << argv[i] << endl;
else
cerr << "Unknown command: " << argv[i] << "; ignored" << endl;
}
}
int isnumlis(int arg){
while(!(IS_NIL(arg)))
if(numberp(car(arg)))
arg = cdr(arg);
else
return(0);
return(1);
}
//--------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);
}
void checkarg(int test, char *fun, int arg){
switch(test){
case NUMLIST_TEST: if(isnumlis(arg)) return; else error(ARG_NUM_ERR, fun, arg);
case SYMBOL_TEST: if(symbolp(arg)) return; else error(ARG_SYM_ERR, fun, arg);
case NUMBER_TEST: if(numberp(arg)) return; else error(ARG_NUM_ERR, fun, arg);
case LIST_TEST: if(listp(arg)) return; else error(ARG_LIS_ERR, fun, arg);
case LEN0_TEST: if(length(arg) == 0) return; else error(ARG_LEN0_ERR, fun, arg);
case LEN1_TEST: if(length(arg) == 1) return; else error(ARG_LEN1_ERR, fun, arg);
case LEN2_TEST: if(length(arg) == 2) return; else error(ARG_LEN2_ERR, fun, arg);
case LEN3_TEST: if(length(arg) == 3) return; else error(ARG_LEN3_ERR, fun, arg);
}
}
void read_rcfile(double pb[]) {
char line[100];
ifstream rcfile(".cmasrc");
double x;
char *pn, *val;
int i, valid;
static char whitespace[] = " \t\n";
static const char tagline[] = "# cmas 2.0";
if (rcfile.bad())
return; // file doesn't exist? just use defaults
rcfile.getline(line,sizeof(line));
if (strcmp(line,tagline)) {
cerr << "Corrupt .cmasrc file? First line must be '" << tagline << "'" << endl;
return;
}
while (rcfile.getline(line,sizeof(line))) {
if (line[0] == 0)
continue;
if (line[0] == '#')
continue;
pn = strtok(line,whitespace);
if (pn)
val = strtok(NULL,whitespace);
for (i = 0; i < NParams; i++)
if (strcmp(ParamTable[i].name,pn) == 0) {
valid = 1;
if (!numberp(val))
valid = 0;
else {
x = atof(val);
if ((x < ParamTable[i].min) || (x > ParamTable[i].max))
valid = 0;
}
break;
}
if (i < NParams)
if (valid)
pb[ParamTable[i].key] = x;
else
cerr << "Bad parameter value: " << pn << ", " << val << endl;
else
cerr << "Unknown parameter file entry: " << pn << "; ignored" << endl;
}
}
/* Check the stack for a compound data argument and return it or NIL */
LOCAL LVAL findcompound P1C(int, skip_one)
{
LVAL *next;
int n;
n = xlargc;
next = xlargv;
if (skip_one) {
n--;
next++;
}
for (; n > 0; n--, next++)
/* pretesting to speed up non-compound case a bit */
if (! numberp(*next) && ! stringp(*next) && compoundp(*next))
return(*next);
return(NIL);
}
// evaluate form x with lexical bindings a
LISPTR eval(LISPTR x)
{
if (consp(x)) {
// evaluate a form
LISPTR f = car(x);
LISPTR args = cdr(x);
x = apply(f, args);
} else if (stringp(x) || numberp(x)) {
return x;
} else if (symbolp(x)) {
LISPTR binding = assoc(x, lexvars);
if (binding != NIL) {
x = cdr(binding);
} else {
x = symbol_value(x);
}
}
return x;
}
print (expr x)
{
/* inutile car pas de cons donc pas de gc */
/* begin_decl ();
decl_expr (&x);
*/
if (numberp(x))
printf ("%d", x);
else if (symbolp(x))
printf ("%s", name_symbol(x));
else
{
printf ("*");
print (car(x));
printf (" ");
print (cdr(x));
}
/* free_expr (); */
}
NODE *runparse(NODE *ndlist) {
NODE *curnd = NIL, *outline = NIL, *tnode = NIL, *lastnode = NIL;
char *str;
if (nodetype(ndlist) == RUN_PARSE)
return parsed__runparse(ndlist);
if (!is_list(ndlist)) {
err_logo(BAD_DATA_UNREC, ndlist);
return(NIL);
}
if (ndlist != NIL && is_word(curnd=car(ndlist)) && getstrlen(curnd) >= 2 &&
(str=getstrptr(curnd)) && *str++ == '#' && *str == '!')
return NIL; /* shell-script #! treated as comment line */
while (ndlist != NIL) {
curnd = car(ndlist);
ndlist = cdr(ndlist);
if (!is_word(curnd))
tnode = cons(curnd, NIL);
else {
if (!numberp(curnd))
tnode = runparse_node(curnd, &ndlist);
else
tnode = cons(cnv_node_to_numnode(curnd), NIL);
}
if (tnode != NIL) {
if (outline == NIL) outline = tnode;
else setcdr(lastnode, tnode);
lastnode = tnode;
while (cdr(lastnode) != NIL) {
lastnode = cdr(lastnode);
if (check_throwing) break;
}
}
if (check_throwing) break;
}
return(outline);
}
NODE *cnv_node_to_numnode(NODE *ndi)
{
NODE *val;
int dr;
char s2[MAX_NUMBER], *s = s2;
if (is_number(ndi))
return (ndi);
ndi = cnv_node_to_strnode(ndi);
if (ndi == UNBOUND) return (UNBOUND);
if (((getstrlen(ndi)) < MAX_NUMBER) && (dr = numberp(ndi)))
{
if (backslashed(ndi))
noparity_strnzcpy(s, getstrptr(ndi), getstrlen(ndi));
else
strnzcpy(s, getstrptr(ndi), getstrlen(ndi));
if (*s == '+') ++s;
if (s2[getstrlen(ndi) - 1] == '.') s2[getstrlen(ndi) - 1] = 0;
if (/*TRUE || */ dr - 1 || getstrlen(ndi) > 9)
{
val = newnode(FLOAT);
setfloat(val, atof(s));
}
else
{
val = newnode(INT);
setint(val, atol(s));
}
gcref(ndi);
return (val);
}
else
{
gcref(ndi);
return (UNBOUND);
}
}
NODE *maybe_quote(NODE *nd)
{
if (nd == UNBOUND || aggregate(nd) || numberp(nd)) return (nd);
return (make_quote(nd));
}
static void
game_usage_info(void)
{
int i, wid, hgt, circumf, lat, lon, pergame, perside, perturn;
const char *varid;
char buf[BUFSIZE];
Variant *var;
Obj *vardflt;
printf("\nGame variant options");
if (mainmodule == NULL) {
printf(":\n\n No game loaded, no information available.\n\n");
return;
}
printf(" for \"%s\":\n\n", mainmodule->name);
if (mainmodule->variants == NULL) {
printf(" No variants available.\n\n");
return;
}
for (i = 0; mainmodule->variants[i].id != lispnil; ++i) {
var = &(mainmodule->variants[i]);
varid = c_string(var->id);
vardflt = var->dflt;
switch (keyword_code(varid)) {
case K_SEE_ALL:
printf(" -V\t\t\t%s (default %s)\n",
var->help,
(vardflt == lispnil ? "true" :
(c_number(eval(vardflt)) ? "true" : "false")));
break;
case K_SEQUENTIAL:
printf(" -seq\t\t%s (default %s)\n",
var->help,
(vardflt == lispnil ? "false" :
(c_number(eval(vardflt)) ? "false" : "true")));
printf(" -sim\t\tSides move simultaneously (opposite of -seq)\n");
break;
case K_WORLD_SEEN:
printf(" -v\t\t\t%s (default %s)\n",
var->help,
(vardflt == lispnil ? "true" :
(c_number(eval(vardflt)) ? "true" : "false")));
break;
case K_WORLD_SIZE:
printf(" -M wid[xhgt][Wcircumf][+lat][+long]\tset world size (default ");
/* Note that if the game definition sets these values
directly using world or area forms, this is misleading;
but that's the fault of the game designer for including
both preset values and a variant whose defaults don't
match those presets. */
circumf = DEFAULTCIRCUMFERENCE;
wid = DEFAULTWIDTH; hgt = DEFAULTHEIGHT;
lat = lon = 0;
/* Pick the width and height out of the list. */
if (vardflt != lispnil) {
wid = c_number(eval(car(vardflt)));
vardflt = cdr(vardflt);
}
if (vardflt != lispnil) {
hgt = c_number(eval(car(vardflt)));
vardflt = cdr(vardflt);
} else {
hgt = wid;
}
/* Pick up a circumference etc if given. */
if (vardflt != lispnil) {
circumf = c_number(eval(car(vardflt)));
vardflt = cdr(vardflt);
}
if (vardflt != lispnil) {
lat = c_number(eval(car(vardflt)));
vardflt = cdr(vardflt);
}
if (vardflt != lispnil) {
lon = c_number(eval(car(vardflt)));
}
printf("%dx%dW%d", wid, hgt, circumf);
if (lat != 0 || lon != 0)
printf("+%d+%d", lat, lon);
printf(")\n");
break;
case K_REAL_TIME:
pergame = perside = perturn = 0;
if (vardflt != lispnil) {
pergame = c_number(eval(car(vardflt)));
vardflt = cdr(vardflt);
}
if (vardflt != lispnil) {
perside = c_number(eval(car(vardflt)));
vardflt = cdr(vardflt);
}
if (vardflt != lispnil) {
perturn = c_number(eval(car(vardflt)));
}
printf(" -tgame mins\t\tlimit game time to <mins> minutes (default %d)\n",
pergame);
printf(" -tside mins\t\tlimit each player <mins> minutes in all (default %d)\n",
perside);
printf(" -tturn mins\t\tlimit each turn to <mins> minutes (default %d)\n",
perturn);
break;
default:
printf(" -v%s[=value]\t%s (default ", varid, var->help);
if (vardflt == lispnil
|| (numberp(vardflt) && c_number(vardflt) == 0)) {
printf("false");
} else if (numberp(vardflt) && c_number(vardflt) == 1) {
printf("true");
} else {
sprintlisp(buf, vardflt, BUFSIZE);
printf("%s", buf);
}
printf(")\n");
break;
}
}
}
int f_numberp(int arglist){
if(numberp(car(arglist)))
return(makeT());
else
return(makeNIL());
}
/* Parenthesize an expression. Set expr to the node after the first full
* expression.
*/
NODE *paren_expr(NODE **expr, BOOLEAN inparen) {
NODE *first = NIL, *tree = NIL, *pproc, *retval;
NODE **ifnode = (NODE **)NIL;
if (*expr == NIL) {
if (inparen) err_logo(PAREN_MISMATCH, NIL);
return *expr;
}
first = car(*expr);
pop(*expr);
if (nodetype(first) == CASEOBJ && !numberp(first)) {
if (first == Left_Paren) {
tree = paren_expr(expr, TRUE);
tree = paren_infix(tree, expr, -1, TRUE);
if (*expr == NIL)
err_logo(PAREN_MISMATCH, NIL);
else if (car(*expr) != Right_Paren) { /* throw the rest away */
int parens;
for (parens = 0; *expr; pop(*expr)) {
if (car(*expr) == Left_Paren)
parens++;
else if (car(*expr) == Right_Paren)
if (parens-- == 0) {
pop(*expr);
break;
}
}
first = tree /* car(tree) */ ; /* 6.0 */
tree = cons(Not_Enough_Node, NIL); /* tell eval */
tree_dk_how=UNBOUND;
if (is_list(first))
first = car(first);
if (nodetype(first) != CASEOBJ ||
procnode__caseobj(first) == UNDEFINED)
err_logo(DK_HOW, first);
else
err_logo(TOO_MUCH, first);
}
else
pop(*expr);
retval = tree;
} else if (first == Right_Paren) {
err_logo(UNEXPECTED_PAREN, NIL);
if (inparen) push(first, *expr);
retval = NIL;
} else if (first == Minus_Sign) {
push(Minus_Tight, *expr);
retval = paren_infix(make_intnode((FIXNUM) 0), expr, -1, inparen);
} else { /* it must be a procedure */
check_library(first);
pproc = procnode__caseobj(first);
if (pproc == UNDEFINED) {
if (missing_space(first)) {
push(missing_numeric, *expr);
first = missing_alphabetic;
pproc = procnode__caseobj(first);
retval = gather_args(first, pproc, expr, inparen, ifnode);
if (retval != UNBOUND) {
retval = cons(first, retval);
}
} else if (is_setter(first)) {
retval = gather_some_args(0, 1, expr, inparen, ifnode);
if (retval != UNBOUND) {
retval = cons(first, retval);
}
} else {
retval = cons(first, NIL);
tree_dk_how = first;
}
} else if (nodetype(pproc) == INFIX && NOT_THROWING) {
err_logo(NOT_ENOUGH, first);
retval = cons(first, NIL);
} else {
/* Kludge follows to turn IF to IFELSE sometimes. */
if (isName(first, Name_if)) {
ifnode = &first;
}
retval = gather_args(first, pproc, expr, inparen, ifnode);
if (retval != UNBOUND) {
retval = cons(first, retval);
}
}
}
} else if (is_list(first)) { /* quoted list */
retval = make_quote(first);
} else {
return first;
}
return retval;
}
int f_numberp(int arglist){
if(numberp(car(arglist)))
return(T);
else
return(NIL);
}
