append (struct coroutine *k,
expr a, expr b, expr c)
{
begin_decl ();
decl_expr (&a);
decl_expr (&b);
decl_expr (&c);
if (alt (k, 1, 0))
/* append ([], L, L) */
{
expr l, var_l;
decl_loc (l);
decl_loc (var_l);
l = UNDEF;
var_l = mk_var (&l);
unify (k, nil, a);
unify (k, var_l, b);
unify (k, var_l, c);
unify (k, a, nil);
unify (k, b, var_l);
unify (k, c, var_l);
}
else
/* append ([X|A], B, [X|C]) :- append (A, B, C) */
if (alt (k, 1, 0))
{
expr X, A, B, C, _X, _A, _B, _C, XA, XC;
dle(X) dle(A) dle(B) dle(X)
dle(_X) dle(_A) dle(_B) dle(_C)
dle(XA) dle(XC)
X = UNDEF;
A = UNDEF;
B = UNDEF;
C = UNDEF;
_X = mk_var (&X);
_A = mk_var (&A);
_B = mk_var (&B);
_C = mk_var (&C);
XA = cons (_X, _A);
XC = cons (_X, _C);
unify (k, XA, a);
unify (k, _B, b);
unify (k, XC, c);
append (k, _A, _B, _C);
unify (k, a, XA);
unify (k, b, _B);
unify (k, c, XC);
} else
end (k);
free_expr ();
}
void
free_expr(st_expr_t *expr)
{
switch(expr->type)
{
case ste_near_lines:
case ste_near:
case ste_or:
case ste_and:
if (expr->subexpr.exprs[0])
free_expr(expr->subexpr.exprs[0]);
if (expr->subexpr.exprs[1])
free_expr(expr->subexpr.exprs[1]);
break;
case ste_not:
if (expr->subexpr.expr)
free_expr(expr->subexpr.expr);
break;
case ste_term:
/* We always free the matches, if there are any. */
if (expr->subexpr.term && expr->subexpr.term->matches)
{
st_match_t *mp, *next;
for (mp = expr->subexpr.term->matches; mp; mp = next)
{
next = mp->next;
free(mp);
}
expr->subexpr.term->matches = 0;
expr->subexpr.term->curmatch = 0;
}
/* We never actually free the terms here, because they should
* be in an array by now.
*/
break;
case ste_matchset:
if (expr->subexpr.set)
free(expr->subexpr.set);
break;
}
free(expr);
}
ParsingErrors
parse(const char input[], var_t *result)
{
expr_t expr_root;
assert(initialized && "Parser must be initialized before use.");
last_error = PE_NO_ERROR;
last_token.type = BEGIN;
last_position = input;
get_next(&last_position);
expr_root = parse_or_expr(&last_position);
last_parsed_char = last_position;
if(last_token.type != END)
{
if(last_parsed_char > input)
{
last_parsed_char--;
}
if(last_error == PE_NO_ERROR)
{
if(last_token.type == DQ && strchr(last_position, '"') == NULL)
{
/* This is a comment, just ignore it. */
last_position += strlen(last_position);
}
else if(eval_expr(&expr_root) == 0)
{
var_free(res_val);
res_val = var_clone(expr_root.value);
last_error = PE_INVALID_EXPRESSION;
}
}
}
if(last_error == PE_NO_ERROR)
{
if(eval_expr(&expr_root) == 0)
{
var_free(res_val);
res_val = var_clone(expr_root.value);
*result = var_clone(expr_root.value);
}
}
if(last_error == PE_INVALID_EXPRESSION)
{
last_position = skip_whitespace(input);
}
free_expr(&expr_root);
return last_error;
}
struct expr *
not(struct expr * e, struct context * ctx)
{
struct expr *a, *re;
if (!e || list_len(e) < 2) {
free_expr(e);
return empty_list();
}
a = eval(e->v.list->next->v, ctx);
if (is_empty_list(a))
re = atom_t();
else
re = empty_list();
full_free_expr(a);
free_expr(e);
return re;
}
static int do_cond(char **s)
{
expr *condexp = parse_expr_tmplab(s);
taddr val;
if (!eval_expr(condexp,&val,NULL,0)) {
general_error(30); /* expression must be constant */
val = 0;
}
free_expr(condexp);
return val != 0;
}
struct expr *
atom(struct expr * e, struct context * ctx)
{
struct expr *a, *re;
int n;
if (!e || list_len(e) < 2) {
free_expr(e);
return empty_list();
}
a = eval(e->v.list->next->v, ctx);
if (a->t == LATOM)
re = atom_t();
else if (a->t == LLIST && list_len(a) == 0)
re = atom_t();
else
re = empty_list();
full_free_expr(a);
free_expr(e);
return re;
}
struct expr *
list(struct expr * e, struct context * ctx)
{
struct expr *pe, *re;
const struct list *l;
int i;
if (!e)
return empty_list();
if (list_len(e) < 2) {
free_expr(e);
return empty_list();
}
re = new_expr(LLIST);
for (i = 1; (l = get_list_el(e, i)) != NULL; ++i) {
pe = eval(l->v, ctx);
list_add(re, pe);
}
free_expr(e);
return re;
}
void evaluate(expr* expression)
{
value_object val = eval_aux(expression);
if (val.type != VAL_NULL)
{
printf(" [");
print_type(val.type);
printf("]");
printf(" = ");
print_value(val);
}
printf("\n");
free_expr(expression);
}
struct expr *
defun(struct expr * e, struct context * ctx)
{
struct expr *pe, *pl;
struct list *l;
if (!e || list_len(e) < 4) {
free_expr(e);
return empty_list();
}
if (!e->v.list->next || !e->v.list->next->v || e->v.list->next->v->t != LATOM || !e->v.list->next->v->v.atom || !e->v.list->next->v->v.atom->v) {
free_expr(e);
return empty_list();
}
if (!e->v.list->next->next || !is_valid_p_expr(e->v.list->next->next->v)) {
free_expr(e);
return empty_list();
}
if (!e->v.list->next->next->next || !e->v.list->next->next->next->v) {
free_expr(e);
return empty_list();
}
pl = new_expr(LLIST);
pl->v.list = new_list();
pl->v.list->v = new_expr(LATOM);
pl->v.list->v->v.atom = new_atom("lambda");
pl->v.list->next = new_list();
pl->v.list->next->v = exprs_dup(e->v.list->next->next->v);
pl->v.list->next->next = new_list();
pl->v.list->next->next->v = exprs_dup(e->v.list->next->next->next->v);
pe = add_to_context(ctx, strdup(e->v.list->next->v->v.atom->v), pl);
full_free_expr(pe);
free_expr(e);
return empty_list();
}
struct expr *
label(struct expr * e, struct context * ctx)
{
struct expr *pe;
if (!e || list_len(e) < 3) {
dbgprintf("first\n");
free_expr(e);
return empty_list();
}
if (!e->v.list->v || e->v.list->v->t != LATOM || !e->v.list->v->v.atom || !e->v.list->v->v.atom->v) {
dbgprintf("second\n");
free_expr(e);
return empty_list();
}
if (!is_valid_lambda_expr(e->v.list->next->next->v)) {
free_expr(e);
return empty_list();
}
pe = add_to_context(ctx, strdup(e->v.list->next->v->v.atom->v), exprs_dup(e->v.list->next->next->v));
full_free_expr(pe);
free_expr(e);
return empty_list();
}
pl_consonne_1 (struct coroutine *k, expr a0)
{
expr nx[MAX_NEW_CONS];
int pnx, i;
struct process_list *alt_process;
pnx = 0;
begin_decl ();
decl_expr (&a0);
for (i=0; i<MAX_NEW_CONS; i++)
dle (nx[i]);
#ifdef TRACE
printf ("\nconsonne: a0 = "); print_expr (a0);
#endif
if (alt (k, 1, 0))
{
/* clause */
expr val_X, var_X;
alt_process = getpl (k) -> alt;
dle(val_X) dle(var_X)
val_X=UNDEF; var_X=mk_var(&val_X);
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
unify (k, var_X, a0);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
pl_lettre_1 (k, var_X);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
pl_non_voyelle_1 (k, var_X);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
unify (k, a0, var_X);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
} else
end (k);
free_expr ();
}
inter (expr x, expr y)
{
expr r, t1;
begin_decl ();
decl_expr (&x);
decl_expr (&y);
r = nil; decl_expr (&r);
t1 = nil; decl_expr (&t1);
if (x > y)
return nil;
/* r = cons (x, inter (x+1, y)); */
t1 = inter (x+1, y);
r = cons (x, t1);
t1 = nil;
free_expr ();
return r;
}
struct expr *
quote(struct expr * e, struct context * ctx)
{
struct expr *re;
int len;
if (e == NULL)
return empty_list();
if (e->quoted) {
re = exprs_dup(e);
re->quoted = 0;
} else {
if (list_len(e) < 2)
re = empty_list();
else
re = exprs_dup(e->v.list->next->v);
}
free_expr(e);
return re;
}
pl_lettre_1 (struct coroutine *k, expr a0)
{
expr nx[MAX_NEW_CONS];
int pnx, i;
struct process_list *alt_process;
pnx = 0;
begin_decl ();
decl_expr (&a0);
for (i=0; i<MAX_NEW_CONS; i++)
dle (nx[i]);
#ifdef TRACE
printf ("\nlettre: a0 = "); print_expr (a0);
#endif
if (alt (k, 1, 0))
{
/* clause */
alt_process = getpl (k) -> alt;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
unify (k, nx[pnx++] = cons (symbol("a"),
0), a0);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
unify (k, a0, nx[pnx++] = cons (symbol("a"),
0));
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
} else
if (alt (k, 1, 0))
{
/* clause */
alt_process = getpl (k) -> alt;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
unify (k, nx[pnx++] = cons (symbol("b"),
0), a0);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
unify (k, a0, nx[pnx++] = cons (symbol("b"),
0));
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
} else
if (alt (k, 1, 0))
{
/* clause */
alt_process = getpl (k) -> alt;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
unify (k, nx[pnx++] = cons (symbol("c"),
0), a0);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
unify (k, a0, nx[pnx++] = cons (symbol("c"),
0));
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
} else
if (alt (k, 1, 0))
{
/* clause */
alt_process = getpl (k) -> alt;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
unify (k, nx[pnx++] = cons (symbol("d"),
0), a0);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
unify (k, a0, nx[pnx++] = cons (symbol("d"),
0));
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
} else
if (alt (k, 1, 0))
{
/* clause */
alt_process = getpl (k) -> alt;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
unify (k, nx[pnx++] = cons (symbol("e"),
0), a0);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
unify (k, a0, nx[pnx++] = cons (symbol("e"),
0));
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
} else
if (alt (k, 1, 0))
{
/* clause */
alt_process = getpl (k) -> alt;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
unify (k, nx[pnx++] = cons (symbol("f"),
0), a0);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
unify (k, a0, nx[pnx++] = cons (symbol("f"),
0));
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
} else
if (alt (k, 1, 0))
{
/* clause */
alt_process = getpl (k) -> alt;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
unify (k, nx[pnx++] = cons (symbol("g"),
0), a0);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
unify (k, a0, nx[pnx++] = cons (symbol("g"),
0));
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
} else
if (alt (k, 1, 0))
{
/* clause */
alt_process = getpl (k) -> alt;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
unify (k, nx[pnx++] = cons (symbol("h"),
0), a0);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
unify (k, a0, nx[pnx++] = cons (symbol("h"),
0));
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
} else
if (alt (k, 1, 0))
{
/* clause */
alt_process = getpl (k) -> alt;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
unify (k, nx[pnx++] = cons (symbol("i"),
0), a0);
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
unify (k, a0, nx[pnx++] = cons (symbol("i"),
0));
for (i=0; i<pnx; i++)
nx[i] = 0;
pnx=0;
#ifdef TRACE
printf ("\n\ta0 = "); print_expr (a0);
#endif
} else
end (k);
free_expr ();
}
int
main (int argc, char **argv)
{
struct expr *e;
int i;
mpz_t r;
int errcode = 0;
char *str;
int base = 10;
setup_error_handler ();
gmp_randinit (rstate, GMP_RAND_ALG_LC, 128);
{
#if HAVE_GETTIMEOFDAY
struct timeval tv;
gettimeofday (&tv, NULL);
gmp_randseed_ui (rstate, tv.tv_sec + tv.tv_usec);
#else
time_t t;
time (&t);
gmp_randseed_ui (rstate, t);
#endif
}
mpz_init (r);
while (argc > 1 && argv[1][0] == '-')
{
char *arg = argv[1];
if (arg[1] >= '0' && arg[1] <= '9')
break;
if (arg[1] == 't')
print_timing = 1;
else if (arg[1] == 'b' && arg[2] >= '0' && arg[2] <= '9')
{
base = atoi (arg + 2);
if (base < 2 || base > 62)
{
fprintf (stderr, "error: invalid output base\n");
exit (-1);
}
}
else if (arg[1] == 'b' && arg[2] == 0)
base = 2;
else if (arg[1] == 'x' && arg[2] == 0)
base = 16;
else if (arg[1] == 'X' && arg[2] == 0)
base = -16;
else if (arg[1] == 'o' && arg[2] == 0)
base = 8;
else if (arg[1] == 'd' && arg[2] == 0)
base = 10;
else if (arg[1] == 'v' && arg[2] == 0)
{
printf ("pexpr linked to gmp %s\n", __gmp_version);
}
else if (strcmp (arg, "-html") == 0)
{
flag_html = 1;
newline = "<br>";
}
else if (strcmp (arg, "-wml") == 0)
{
flag_wml = 1;
newline = "<br/>";
}
else if (strcmp (arg, "-split") == 0)
{
flag_splitup_output = 1;
}
else if (strcmp (arg, "-noprint") == 0)
{
flag_print = 0;
}
else
{
fprintf (stderr, "error: unknown option `%s'\n", arg);
exit (-1);
}
argv++;
argc--;
}
for (i = 1; i < argc; i++)
{
int s;
int jmpval;
/* Set up error handler for parsing expression. */
jmpval = setjmp (errjmpbuf);
if (jmpval != 0)
{
fprintf (stderr, "error: %s%s\n", error, newline);
fprintf (stderr, " %s%s\n", argv[i], newline);
if (! flag_html)
{
/* ??? Dunno how to align expression position with arrow in
HTML ??? */
fprintf (stderr, " ");
for (s = jmpval - (long) argv[i]; --s >= 0; )
putc (' ', stderr);
fprintf (stderr, "^\n");
}
errcode |= 1;
continue;
}
str = expr (argv[i], &e);
if (str[0] != 0)
{
fprintf (stderr,
"error: garbage where end of expression expected%s\n",
newline);
fprintf (stderr, " %s%s\n", argv[i], newline);
if (! flag_html)
{
/* ??? Dunno how to align expression position with arrow in
HTML ??? */
fprintf (stderr, " ");
for (s = str - argv[i]; --s; )
putc (' ', stderr);
fprintf (stderr, "^\n");
}
errcode |= 1;
free_expr (e);
continue;
}
/* Set up error handler for evaluating expression. */
if (setjmp (errjmpbuf))
{
fprintf (stderr, "error: %s%s\n", error, newline);
fprintf (stderr, " %s%s\n", argv[i], newline);
if (! flag_html)
{
/* ??? Dunno how to align expression position with arrow in
HTML ??? */
fprintf (stderr, " ");
for (s = str - argv[i]; --s >= 0; )
putc (' ', stderr);
fprintf (stderr, "^\n");
}
errcode |= 2;
continue;
}
if (print_timing)
{
int t;
TIME (t, mpz_eval_expr (r, e));
printf ("computation took %d ms%s\n", t, newline);
}
else
mpz_eval_expr (r, e);
if (flag_print)
{
size_t out_len;
char *tmp, *s;
out_len = mpz_sizeinbase (r, base >= 0 ? base : -base) + 2;
#ifdef LIMIT_RESOURCE_USAGE
if (out_len > 100000)
{
printf ("result is about %ld digits, not printing it%s\n",
(long) out_len - 3, newline);
exit (-2);
}
#endif
tmp = malloc (out_len);
if (print_timing)
{
int t;
printf ("output conversion ");
TIME (t, mpz_get_str (tmp, base, r));
printf ("took %d ms%s\n", t, newline);
}
else
mpz_get_str (tmp, base, r);
out_len = strlen (tmp);
if (flag_splitup_output)
{
for (s = tmp; out_len > 80; s += 80)
{
fwrite (s, 1, 80, stdout);
printf ("%s\n", newline);
out_len -= 80;
}
fwrite (s, 1, out_len, stdout);
}
else
{
fwrite (tmp, 1, out_len, stdout);
}
free (tmp);
printf ("%s\n", newline);
}
else
{
printf ("result is approximately %ld digits%s\n",
(long) mpz_sizeinbase (r, base >= 0 ? base : -base),
newline);
}
free_expr (e);
}
exit (errcode);
}
main (int argc, char **argv)
{
struct expr *e;
int i;
mpz_t r;
int errcode = 0;
char *str;
int base = 10;
#if !defined(_WIN32) && !defined(__DJGPP__)
setup_error_handler ();
#endif
mpz_init (r);
while (argc > 1 && argv[1][0] == '-')
{
char *arg = argv[1];
if (arg[1] >= '0' && arg[1] <= '9')
break;
if (arg[1] == 't')
print_timing = 1;
else if (arg[1] == 'b' && arg[2] >= '0' && arg[2] <= '9')
{
base = atoi (arg + 2);
if (base < 2 || base > 36)
{
fprintf (stderr, "error: invalid output base\n");
exit (-1);
}
}
else if (arg[1] == 'b' && arg[2] == 0)
base = 2;
else if (arg[1] == 'x' && arg[2] == 0)
base = 16;
else if (arg[1] == 'o' && arg[2] == 0)
base = 8;
else if (arg[1] == 'd' && arg[2] == 0)
base = 10;
else if (strcmp (arg, "-html") == 0)
{
flag_html = 1;
newline = "<BR>";
}
else if (strcmp (arg, "-split") == 0)
{
flag_splitup_output = 1;
}
else if (strcmp (arg, "-noprint") == 0)
{
flag_print = 0;
}
else
{
fprintf (stderr, "error: unknown option `%s'\n", arg);
exit (-1);
}
argv++;
argc--;
}
for (i = 1; i < argc; i++)
{
int s;
int jmpval;
/* Set up error handler for parsing expression. */
jmpval = setjmp (errjmpbuf);
if (jmpval != 0)
{
fprintf (stderr, "error: %s%s\n", error, newline);
fprintf (stderr, " %s%s\n", argv[i], newline);
if (! flag_html)
{
/* ??? Dunno how to align expression position with arrow in
HTML ??? */
fprintf (stderr, " ");
for (s = jmpval - (long) argv[i]; --s >= 0; )
putc (' ', stderr);
fprintf (stderr, "^\n");
}
errcode |= 1;
continue;
}
str = expr (argv[i], &e);
if (str[0] != 0)
{
fprintf (stderr,
"error: garbage where end of expression expected%s\n",
newline);
fprintf (stderr, " %s%s\n", argv[i], newline);
if (! flag_html)
{
/* ??? Dunno how to align expression position with arrow in
HTML ??? */
fprintf (stderr, " ");
for (s = str - argv[i]; --s; )
putc (' ', stderr);
fprintf (stderr, "^\n");
}
errcode |= 1;
free_expr (e);
continue;
}
/* Set up error handler for evaluating expression. */
if (setjmp (errjmpbuf))
{
fprintf (stderr, "error: %s%s\n", error, newline);
fprintf (stderr, " %s%s\n", argv[i], newline);
if (! flag_html)
{
/* ??? Dunno how to align expression position with arrow in
HTML ??? */
fprintf (stderr, " ");
for (s = str - argv[i]; --s >= 0; )
putc (' ', stderr);
fprintf (stderr, "^\n");
}
errcode |= 2;
continue;
}
{
int t0;
if (print_timing)
t0 = cputime ();
mpz_eval_expr (r, e);
if (print_timing)
printf ("computation took %d ms%s\n", cputime () - t0, newline);
}
if (flag_print)
{
size_t out_len;
char *tmp, *s;
int t0;
out_len = mpz_sizeinbase (r, base) + 1;
tmp = malloc (out_len);
if (print_timing)
t0 = cputime ();
if (print_timing)
/* Print first half of message... */
printf ("output conversion ");
mpz_get_str (tmp, -base, r);
if (print_timing)
/* ...print 2nd half of message unless we caught a time limit
and therefore longjmp'ed */
printf ("took %d ms%s\n", cputime () - t0, newline);
out_len = strlen (tmp);
if (flag_splitup_output)
{
for (s = tmp; out_len > 60; s += 60)
{
fwrite (s, 1, 60, stdout);
printf ("%s\n", newline);
out_len -= 60;
}
fwrite (s, 1, out_len, stdout);
}
else
{
fwrite (tmp, 1, out_len, stdout);
}
free (tmp);
printf ("%s\n", newline);
}
else
{
printf ("result is approximately %ld digits%s\n",
(long) mpz_sizeinbase (r, 10), newline);
}
free_expr (e);
}
exit (errcode);
}
append (struct coroutine *k,
expr a, expr b, expr c)
{
#ifndef OLD
begin_decl ();
decl_expr (&a);
decl_expr (&b);
decl_expr (&c);
#endif
#ifdef TRACE
printf ("\na = "); print_expr (a);
printf ("\nb = "); print_expr (b);
printf ("\nc = "); print_expr (c);
#endif
if (alt (k, 1, 0))
/* append ([], L, L) */
{
expr l, var_l;
#ifndef OLD
decl_loc (l);
decl_loc (var_l);
#endif
l = UNDEF;
var_l = mk_var (&l);
unify (k, nil, a);
unify (k, var_l, b);
unify (k, var_l, c);
#ifdef TRACE
printf ("\nvar_l = "); print_expr (var_l);
#endif
unify (k, a, nil);
unify (k, b, var_l);
unify (k, c, var_l);
#ifdef TRACE
printf ("\na = "); print_expr (a);
printf ("\nb = "); print_expr (b);
printf ("\nc = "); print_expr (c);
#endif
/* free (var_l); */
}
else
/* append ([X|A], B, [X|C]) :- append (A, B, C) */
{
expr X, A, B, C, _X, _A, _B, _C, XA, XC;
#ifndef OLD
dle(X) dle(A) dle(B) dle(X)
dle(_X) dle(_A) dle(_B) dle(_C)
dle(XA) dle(XC)
#endif
X = UNDEF;
A = UNDEF;
B = UNDEF;
C = UNDEF;
_X = mk_var (&X);
_A = mk_var (&A);
_B = mk_var (&B);
_C = mk_var (&C);
XA = cons (_X, _A);
XC = cons (_X, _C);
#ifdef TRACE
printf ("\nXA = "); print_expr (XA);
printf ("\n_B = "); print_expr (_B);
printf ("\nXC = "); print_expr (XC);
printf ("\na = "); print_expr (a);
printf ("\nb = "); print_expr (b);
printf ("\nc = "); print_expr (c);
#endif
unify (k, XA, a);
unify (k, _B, b);
unify (k, XC, c);
#ifdef TRACE
printf ("\nXA = "); print_expr (XA);
printf ("\n_B = "); print_expr (_B);
printf ("\nXC = "); print_expr (XC);
#endif
append (k, _A, _B, _C);
#ifdef TRACE
printf ("\n_A = "); print_expr (_A);
printf ("\n_B = "); print_expr (_B);
printf ("\n_C = "); print_expr (_C);
printf ("\nXA = "); print_expr (XA);
printf ("\n_B = "); print_expr (_B);
printf ("\nXC = "); print_expr (XC);
#endif
unify (k, a, XA);
unify (k, b, _B);
unify (k, c, XC);
#ifdef TRACE
printf ("\na = "); print_expr (a);
printf ("\nb = "); print_expr (b);
printf ("\nc = "); print_expr (c);
#endif
/*
free (_X);
free (_A);
free (_B);
free (_C);
free (XA);
free (XC);
*/
}
#ifndef OLD
free_expr ();
#endif
}
struct expr *
eval(struct expr * e, struct context * ctx)
{
int i, is_root_level;
struct expr *pa, *pb, *pc, *pe, **ev, *re;
if (ctx->is_root_level) {
is_root_level = 1;
ctx->is_root_level = 0;
} else {
is_root_level = 0;
}
dbgprintf("\n>>> EVAL <<<\n");
if (dflag) {
peval(e, "@ ");
pcontext(ctx, "< ");
}
if (e == NULL) {
dbgprintf(">>> NULL\n");
re = empty_list();
if (is_root_level) {
free_expr(e);
free(e);
}
return re;
}
if (e->quoted) {
dbgprintf(">>> QUOTE\n");
re = quote(e, ctx);
if (is_root_level) {
free_expr(e);
free(e);
}
return re;
}
if (e->t == LATOM) {
dbgprintf(">>> RET ATOM\n");
if ((pe = search_context(ctx, e->v.atom->v)) != NULL) {
re = exprs_dup(pe);
if (is_root_level) {
free_expr(e);
free(e);
}
return re;
} else {
re = exprs_dup(e);
if (is_root_level) {
free_expr(e);
free(e);
}
return re;
}
} else if (e->t == LLIST) {
if (e->v.list == NULL)
return exprs_dup(e);
if (!e->v.list->v->v.list)
return empty_list();
if (e->v.list->v->t == LATOM) {
for (i = 0; ops[i] != NULL; ++i) {
if (!strcmp(ops[i], e->v.list->v->v.atom->v))
break;
}
if (ops[i] == NULL) {
if (pe = search_context(ctx, e->v.list->v->v.atom->v)) {
free_expr(e->v.list->v);
e->v.list->v = exprs_dup(pe);
return eval(e, ctx);
} else {
return empty_list();
}
}
dbgprintf(">>> %s\n", ops[i]);
re = op_funcs[i] (e, ctx);
if (is_root_level) {
free_expr(e);
free(e);
}
return re;
} else if (e->v.list->v->t == LLIST) {
/* First check if it's a lambda */
if (is_function_call_expr(e)) {
dbgprintf(">>> IS FUNCTION CALL\n");
re = lambda(e, ctx);
if (is_root_level) {
free_expr(e);
free(e);
}
return re;
} else {
dbgprintf(">>> IS NOT FUNCTION CALL\n");
pe = eval(e->v.list->v, ctx);
free_expr(e->v.list->v);
e->v.list->v = (struct expr *) pe;
re = eval(e, ctx);
if (is_root_level) {
free_expr(e);
free(e);
}
return re;
}
}
}
return NULL;
}
void free_expr(struct expr_node *expr)
{
if(expr->left) free_expr(expr->left);
if(expr->right) free_expr(expr->right);
free(expr);
}
void init_game()
{
struct array_mem_small *msmall;
struct array_mem_mid *mmid;
struct array_mem_norm *mlarge;
struct Process *proc;
struct instruction_node *in;
struct process_thread *pthread;
struct process_task *ptask;
int next_offs,proc_offs,pos;
double xx,lato_x,lato_y;
if(arena_mem_type==MEM_TYPE_ONE)
{
msmall=(struct array_mem_small*)malloc(sizeof(struct array_mem_small)*size_arena);
if(msmall==NULL) die("error malloking small array mem");
bzero(msmall,sizeof(struct array_mem_small)*size_arena);
arena=msmall;
}
if(arena_mem_type==MEM_TYPE_TWO)
{
mmid=(struct array_mem_mid*)malloc(sizeof(struct array_mem_mid)*size_arena);
if(mmid==NULL) die("error malloking mid array mem");
bzero(mmid,sizeof(struct array_mem_mid)*size_arena);
arena=mmid;
}
if(arena_mem_type==MEM_TYPE_FOUR)
{
mlarge=(struct array_mem_norm*)malloc(sizeof(struct array_mem_norm)*size_arena);
if(mlarge==NULL) die("error malloking large array mem");
bzero(mlarge,sizeof(struct array_mem_norm)*size_arena);
arena=mlarge;
}
next_offs=0;
for(proc=proc_primo;proc;proc=proc->next)
{
//calc offset in mem
proc_offs=(next_offs+(rand()%min_distance))%size_arena;
//put in mem
pos=proc_offs;
for(in=proc->pc->first;in;in=in->next)
{
putcode(pos++,proc->processID,in->code);
}
//create pt
pthread=(struct process_thread*)malloc(sizeof(struct process_thread));
if(pthread==NULL) die("error alloking new thread");
pthread->IP=proc_offs+(atoi(proc->pc->org));
pthread->communication_in_a=0;
pthread->communication_out_a=0;
pthread->communication_in_b=0;
pthread->communication_out_b=0;
pthread->prev=NULL;
pthread->next=NULL;
pthread->ptask=NULL;
ptask=(struct process_task*)malloc(sizeof(struct process_task));
if(ptask==NULL) die("error alloking new task");
ptask->ID=proc->processID;
ptask->n_threads=1;
ptask->prev=NULL;
ptask->next=NULL;
ptask->primo_thread=NULL;
ptask->ultimo_thread=NULL;
ptask->cur_thread=pthread;
ptask->communication_in_a=0;
ptask->communication_out_a=0;
ptask->communication_in_b=0;
ptask->communication_out_b=0;
get_symbols(&ptask->out_symbol,&ptask->out_color);
//add pt
add_thread(pthread,ptask);
add_task(ptask);
//recalc next_offs
next_offs+=proc_offs+proc->pc->len;
//free proc&pc
in=proc->pc->first;
do{
if(in->left) free_expr(in->left);
if(in->right) free_expr(in->right);
if(in->code) free(in->code);
if(in->next) {in=in->next;free(in->prev);}
else {free(in);in=NULL;}
}while(in!=NULL);
}
xx=sqrt(size_arena);
lato_y=rint(xx);
lato_x=ceil(xx);
max_x=(int)lato_x;
max_y=(int)lato_y;
if(output_mode>=OUTPUT_DEBUG)
{
sprintf(out_str,"max_x=%d max_y=%d\n",max_x,max_y);
fputs(out_str,fpout);
}
//init_graph
if(vo_mode==VO_FRAMEBUFFER) init_txt();
if(vo_mode==VO_X11) init_x11();
}
struct expr *parse_expr()
{
int error = 0, current = current_token;
token t;
token_type type;
struct expr *e;
e = malloc(sizeof(struct expr));
if (e == NULL)
{
perror("No memory");
return NULL;
}
if ((e->data.id = parse_id()) != NULL)
{
e->type = E_ID;
return e;
}
if ((e->data.number = parse_number()) != NULL)
{
e->type = E_NUMBER;
return e;
}
t = get_token();
switch (t.type)
{
case T_SUM:
case T_DIFF:
case T_PRODUKT:
case T_QUOSHUNT:
case T_MOD:
case T_BIGGR:
case T_SMALLR:
type = t.type;
t = get_token();
if (t.type != T_OF)
{
error = 1;
parse_error("expected `OF`");
}
else
{
e->data.exprs.e1 = parse_expr();
if (e->data.exprs.e1 == NULL)
{
error = 1;
}
else
{
t = get_token();
if (t.type != T_AN)
{
error = 1;
parse_error("exptected `AN`");
}
else
{
e->data.exprs.e2 = parse_expr();
if (e->data.exprs.e2 == NULL)
{
free_expr(e->data.exprs.e1);
error = 1;
}
}
}
}
switch (type)
{
case T_SUM:
e->type = E_SUM;
break;
case T_DIFF:
e->type = E_DIFF;
break;
case T_PRODUKT:
e->type = E_PROD;
break;
case T_QUOSHUNT:
e->type = E_QUO;
break;
case T_MOD:
e->type = E_MOD;
break;
case T_BIGGR:
e->type = E_MAX;
break;
case T_SMALLR:
e->type = E_MIN;
break;
default:
break;
}
break;
default:
unget_token();
parse_error("expected expression");
error = 1;
}
if (error == 1)
{
current_token = current;
free(e);
return NULL;
}
return e;
}
