environment decl_attributes::apply(environment env, io_state const & ios, name const & d) const {
if (m_is_instance) {
if (m_priority) {
#if defined(__GNUC__) && !defined(__CLANG__)
#pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
env = add_instance(env, d, *m_priority, m_persistent);
} else {
env = add_instance(env, d, m_persistent);
}
}
if (m_is_trans_instance) {
if (m_priority) {
#if defined(__GNUC__) && !defined(__CLANG__)
#pragma GCC diagnostic ignored "-Wmaybe-uninitialized"
#endif
env = add_trans_instance(env, d, *m_priority, m_persistent);
} else {
env = add_trans_instance(env, d, m_persistent);
}
}
if (m_is_coercion)
env = add_coercion(env, ios, d, m_persistent);
auto decl = env.find(d);
if (decl && decl->is_definition()) {
if (m_is_reducible)
env = set_reducible(env, d, reducible_status::Reducible, m_persistent);
if (m_is_irreducible)
env = set_reducible(env, d, reducible_status::Irreducible, m_persistent);
if (m_is_semireducible)
env = set_reducible(env, d, reducible_status::Semireducible, m_persistent);
if (m_is_quasireducible)
env = set_reducible(env, d, reducible_status::Quasireducible, m_persistent);
if (m_unfold_hint)
env = add_unfold_hint(env, d, m_unfold_hint, m_persistent);
if (m_unfold_full_hint)
env = add_unfold_full_hint(env, d, m_persistent);
}
if (m_constructor_hint)
env = add_constructor_hint(env, d, m_persistent);
if (m_symm)
env = add_symm(env, d, m_persistent);
if (m_refl)
env = add_refl(env, d, m_persistent);
if (m_trans)
env = add_trans(env, d, m_persistent);
if (m_subst)
env = add_subst(env, d, m_persistent);
if (m_recursor)
env = add_user_recursor(env, d, m_recursor_major_pos, m_persistent);
if (m_is_class)
env = add_class(env, d, m_persistent);
if (m_rewrite)
env = add_rewrite_rule(env, d, m_persistent);
if (m_has_multiple_instances)
env = mark_multiple_instances(env, d, m_persistent);
return env;
}
void initialize_inliner() {
register_system_attribute(basic_attribute::with_check(
"inline", "mark definition to always be inlined",
[](environment const & env, name const & d, bool) -> void {
auto decl = env.get(d);
if (!decl.is_definition() || decl.is_theorem())
throw exception(
"invalid 'inline' use, only definitions can be marked as inline");
}));
}
data_t *eval(const data_t *exp, data_t *env) {
if(eval_plz_die) {
eval_plz_die = 0;
ExitThread(0);
}
if(is_self_evaluating(exp))
return (data_t*)exp;
if(is_variable(exp))
return lookup_variable_value(exp, env);
if(is_quoted_expression(exp))
return get_text_of_quotation(exp);
if(is_assignment(exp))
return eval_assignment(exp, env);
if(is_definition(exp))
return eval_definition(exp, env);
if(is_if(exp))
return eval_if(exp, env);
if(is_lambda(exp))
return make_procedure(get_lambda_parameters(exp), get_lambda_body(exp), env);
if(is_begin(exp))
return eval_sequence(get_begin_actions(exp), env);
if(is_cond(exp))
return eval(cond_to_if(exp), env);
if(is_letrec(exp))
return eval(letrec_to_let(exp), env);
if(is_let_star(exp))
return eval(let_star_to_nested_lets(exp), env);
if(is_let(exp))
return eval(let_to_combination(exp), env);
if(is_application(exp))
return apply(
eval(get_operator(exp), env),
get_list_of_values(get_operands(exp), env));
printf("Unknown expression type -- EVAL '");
return make_symbol("error");
}
object *eval(object *exp, object *env) {
object *procedure;
object *arguments;
object *result;
bool tailcall = false;
do {
if (is_self_evaluating(exp))
return exp;
if (is_variable(exp))
return lookup_variable_value(exp, env);
if (is_quoted(exp))
return text_of_quotation(exp);
if (is_assignment(exp))
return eval_assignment(exp, env);
if (is_definition(exp))
return eval_definition(exp, env);
if (is_if(exp)) {
exp = is_true(eval(if_predicate(exp), env)) ? if_consequent(exp) : if_alternative(exp);
tailcall = true;
continue;
}
if (is_lambda(exp))
return make_compound_proc(lambda_parameters(exp), lambda_body(exp), env);
if (is_begin(exp)) {
exp = begin_actions(exp);
while (!is_last_exp(exp)) {
eval(first_exp(exp), env);
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_cond(exp)) {
exp = cond_to_if(exp);
tailcall = true;
continue;
}
if (is_let(exp)) {
exp = let_to_application(exp);
tailcall = true;
continue;
}
if (is_and(exp)) {
exp = and_tests(exp);
if (is_empty(exp))
return make_boolean(true);
while (!is_last_exp(exp)) {
result = eval(first_exp(exp), env);
if (is_false(result))
return result;
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_or(exp)) {
exp = or_tests(exp);
if (is_empty(exp)) {
return make_boolean(false);
}
while (!is_last_exp(exp)) {
result = eval(first_exp(exp), env);
if (is_true(result))
return result;
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_application(exp)) {
procedure = eval(operator(exp), env);
arguments = list_of_values(operands(exp), env);
if (is_primitive_proc(procedure) && procedure->data.primitive_proc.fn == eval_proc) {
exp = eval_expression(arguments);
env = eval_environment(arguments);
tailcall = true;
continue;
}
if (is_primitive_proc(procedure) && procedure->data.primitive_proc.fn == apply_proc) {
procedure = apply_operator(arguments);
arguments = apply_operands(arguments);
}
if (is_primitive_proc(procedure))
return (procedure->data.primitive_proc.fn)(arguments);
if (is_compound_proc(procedure)) {
env = extend_environment(procedure->data.compound_proc.parameters, arguments, procedure->data.compound_proc.env);
exp = make_begin(procedure->data.compound_proc.body);
tailcall = true;
continue;
}
return make_error(342, "unknown procedure type");
} // is_application()
} while (tailcall);
fprintf(stderr, "cannot eval unknown expression type\n");
exit(EXIT_FAILURE);
}
void process_paragraph(char *words[], size_t number, xmlNodePtr node) {
double bins[20000] = { 0 };
size_t i=0;
int recorded_bin = 0;
for (i=0; i<20000; i++) bins[i]=0;
struct document_frequencies_hash *word_entry;
unsigned int paragraph_word_count = 0;
int counters_threshold_a[3];
int counters_threshold_b[3];
int counters_threshold_c[3];
int counters_threshold_d[3];
for (i = 0; i < 3; i++) {
counters_threshold_a[i] = 0;
counters_threshold_b[i] = 0;
counters_threshold_c[i] = 0;
counters_threshold_d[i] = 0;
}
for (i=0; i<number; i++) {
paragraph_word_count++;
struct document_frequencies_hash* bin_entry;
record_word(&DF_prime, words[i]);
HASH_FIND_STR(DF, words[i], word_entry);
//double word_tf = 0.5 + (0.5 * word_entry->count)/doc_max_count;
double word_tf = word_entry->count; //applying both normalizations doesn't work
// Lookup the IDF:
struct score_hash* idf_entry;
HASH_FIND_STR(idf, words[i], idf_entry);
double word_idf = 13;
if(idf_entry!=NULL) {
word_idf = idf_entry->score;
}
else {
// Hardcoding anything missing as a term (corpus-wise)
// that's what log2(8800 / 1) computes to anyway:
word_idf = 13;
}
HASH_FIND_STR(word_to_bin, words[i], bin_entry);
if (bin_entry != NULL) {
int bin = bin_entry->count;
// We're using bins, numbered by the word stem and valued with the TFxIDF scores
// Compute the TF:
recorded_bin = 1;
bins[bin] += (word_tf * word_idf) / tfc_doc_normalization_divisor;
HASH_FIND_STR(DF_prime, words[i], word_entry);
if (word_entry->count < 4) { //word is recorded already
if (bins[bin] > 0.4) counters_threshold_d[word_entry->count - 1]++;
if (bins[bin] > 0.12) counters_threshold_c[word_entry->count - 1]++;
if (word_idf > 4.0) counters_threshold_b[word_entry->count - 1]++;
if (word_idf > 7.5) counters_threshold_a[word_entry->count - 1]++;
}
}
}
if (recorded_bin) {// Some paras have no content words, skip.
// We have the paragraph vector, now map it into a TF/IDF vector and write down a labeled training instance:
int label = is_definition(node->parent) ? 1 : -1;
fprintf(result_file, "%d",label);
for (i=0; i<3; i++) {
fprintf(result_file, " %ld:%d", 4*i, counters_threshold_a[i]);
fprintf(result_file, " %ld:%d", 4*i+1, counters_threshold_b[i]);
fprintf(result_file, " %ld:%d", 4*i+2, counters_threshold_c[i]);
fprintf(result_file, " %ld:%d", 4*i+3, counters_threshold_d[i]);
}
fprintf(result_file, " %d:%d", 13, paragraph_word_count);
for (i=0; i<20000; i++) {
if(bins[i] > 0.0005) {
//if (i%5 == 0) printf("%3.4f\n", 100*bins[i]);
// We also need to normalize on the basis of paragraph length
fprintf(result_file, " %ld:%f", 13+i,bins[i]);
}
}
fprintf(result_file,"\n");
}
}
object *bs_eval(object *exp, object *env)
{
tailcall:
if (is_empty_list(exp)) {
error("unable to evaluate empty list");
} else if (is_self_evaluating(exp)) {
return exp;
} else if (is_variable(exp)) {
return lookup_variable_value(exp, env);
} else if (is_quoted(exp)) {
return quoted_expression(exp);
} else if (is_assignment(exp)) {
return eval_assignment(exp, env);
} else if (is_definition(exp)) {
return eval_definition(exp, env);
} else if (is_if(exp)) {
if (is_true(bs_eval(if_predicate(exp), env))) {
exp = if_consequent(exp);
} else {
exp = if_alternate(exp);
}
goto tailcall;
} else if (is_lambda(exp)) {
return make_compound_proc(lambda_parameters(exp),
lambda_body(exp),
env);
} else if (is_begin(exp)) {
exp = begin_actions(exp);
if (is_empty_list(exp)) {
error("empty begin block");
}
while (!is_empty_list(cdr(exp))) {
bs_eval(car(exp), env);
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_cond(exp)) {
exp = cond_to_if(exp);
goto tailcall;
} else if (is_let(exp)) {
exp = let_to_application(exp);
goto tailcall;
} else if (is_and(exp)) {
exp = and_tests(exp);
if (is_empty_list(exp)) {
return get_boolean(1);
}
object *result;
while (!is_empty_list(cdr(exp))) {
result = bs_eval(car(exp), env);
if (is_false(result)) {
return result;
}
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_or(exp)) {
exp = or_tests(exp);
if (is_empty_list(exp)) {
return get_boolean(0);
}
object *result;
while (!is_empty_list(cdr(exp))) {
result = bs_eval(car(exp), env);
if (is_true(result)) {
return result;
}
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_application(exp)) {
object *procedure = bs_eval(application_operator(exp), env);
object *parameters = eval_parameters(application_operands(exp), env);
// handle eval specially for tailcall requirement.
if (is_primitive_proc(procedure) &&
procedure->value.primitive_proc == eval_proc) {
exp = eval_expression(parameters);
env = eval_environment(parameters);
goto tailcall;
}
// handle apply specially for tailcall requirement.
if (is_primitive_proc(procedure) &&
procedure->value.primitive_proc == apply_proc) {
procedure = apply_operator(parameters);
parameters = apply_operands(parameters);
}
if (is_primitive_proc(procedure)) {
return (procedure->value.primitive_proc)(parameters);
} else if (is_compound_proc(procedure)) {
env = extend_environment(
procedure->value.compound_proc.parameters,
parameters,
procedure->value.compound_proc.env);
exp = make_begin(procedure->value.compound_proc.body);
goto tailcall;
} else {
error("unable to apply unknown procedure type");
}
} else {
error("unable to evaluate expression");
}
}
static tree
parse_raw_coq (string s) {
tree doc (DOCUMENT), proof (DOCUMENT);
tree *r= &doc;
int i= 0, startcmd= 0, n= N(s), indent_level=-1;
bool in_cmd= false;
while (i<n) {
if (!in_cmd && start_comment (s, i)) {
if (start_coqdoc (s, i))
*r << parse_coqdoc (s, i);
else if (is_hide_or_show (s, i))
*r << parse_coqdoc_hide_show (s, i);
else
*r << parse_comment (s, i);
}
else if (start_comment (s, i)) {
if (is_hide_or_show (s, i))
*r << parse_coqdoc_hide_show (s, i);
else
parse_comment (s, i);
}
else if (end_vernac_command (s, i)) {
string body= s (startcmd, ++i);
if (is_enunciation (body)) {
*r << parse_enunciation (body);
r= &proof;
}
else if (is_definition (body)) {
*r << parse_enunciation (body);
}
else {
tree tmp= parse_vernac_command (body);
if (begin_proof (tmp) && end_proof (tmp)) {
proof << parse_vernac_proof (body);
doc << format_proof (proof);
proof= tree (DOCUMENT);
r= &doc;
}
else if (r == &proof) {
if (end_proof (tmp)) {
proof << tmp;
doc << format_proof (proof);
proof= tree (DOCUMENT);
r= &doc;
}
else if (begin_proof (tmp)) {
r= &proof;
*r << parse_vernac_proof (body);
}
else
*r << tmp;
}
else if (begin_proof (tmp)) {
r= &proof;
*r << parse_vernac_proof (body);
}
else
*r << tmp;
}
in_cmd= false;
}
else if (!in_cmd && s[i] == '\n') {
i++;
int tmp= parse_indent (s, i);
if (tmp >= 0 && tmp != indent_level) {
*r << compound ("coq-indent", as_string (tmp));
indent_level= tmp;
}
else if (i < n && s[i] == '\n') {
*r << "";
while (i+1 < n && s[i+1] == '\n') i++;
}
}
else {
if (!in_cmd && !is_blank (s[i])) {
in_cmd= true;
startcmd= i;
}
i++;
}
}
if (N(proof) > 0)
doc << format_proof (proof);
if (in_cmd)
doc << parse_vernac_command (s (startcmd, n));
return doc;
}
static int command()
{
FILE *fp;
int i;
/* string holding name of save or load file */
char sv_file[MAX_LINE_LEN + 1];
for (i = 0; i < MAX_NUM_VAR; i++)
c_dummy_var[i][0] = NUL; /* no dummy variables */
if (is_definition(c_token))
define();
else if (almost_equals(c_token, "h$elp") || equals(c_token, "?")) {
c_token++;
do_help(1);
} else if (equals(c_token, "testtime")) {
/* given a format and a time string, exercise the time code */
char format[160], string[160];
struct tm tm;
double secs;
if (isstring(++c_token)) {
quote_str(format, c_token, 159);
if (isstring(++c_token)) {
quote_str(string, c_token++, 159);
memset(&tm, 0, sizeof(tm));
gstrptime(string, format, &tm);
secs = gtimegm(&tm);
fprintf(stderr, "internal = %f - %d/%d/%d::%d:%d:%d , wday=%d, yday=%d\n",
secs, tm.tm_mday, tm.tm_mon + 1, tm.tm_year % 100, tm.tm_hour, tm.tm_min, tm.tm_sec, tm.tm_wday, tm.tm_yday);
memset(&tm, 0, sizeof(tm));
ggmtime(&tm, secs);
gstrftime(string, 159, format, secs);
fprintf(stderr, "convert back \"%s\" - %d/%d/%d::%d:%d:%d , wday=%d, yday=%d\n",
string, tm.tm_mday, tm.tm_mon + 1, tm.tm_year % 100, tm.tm_hour, tm.tm_min, tm.tm_sec, tm.tm_wday, tm.tm_yday);
}
}
} else if (almost_equals(c_token, "test")) {
c_token++;
test_term();
} else if (almost_equals(c_token, "scr$eendump")) {
c_token++;
#ifdef _Windows
screen_dump();
#else
fputs("screendump not implemented\n", stderr);
#endif
} else if (almost_equals(c_token, "pa$use")) {
struct value a;
int sleep_time, text = 0;
char buf[MAX_LINE_LEN + 1];
c_token++;
sleep_time = (int) real(const_express(&a));
buf[0] = NUL;
if (!(END_OF_COMMAND)) {
if (!isstring(c_token))
int_error("expecting string", c_token);
else {
quote_str(buf, c_token, MAX_LINE_LEN);
++c_token;
#ifdef _Windows
if (sleep_time >= 0)
#else
# ifdef OS2
if (strcmp(term->name, "pm") != 0 || sleep_time >= 0)
# else
# ifdef MTOS
if (strcmp(term->name, "mtos") != 0 || sleep_time >= 0)
# endif /* MTOS */
# endif /* OS2 */
#endif /* _Windows */
fputs(buf, stderr);
text = 1;
}
}
if (sleep_time < 0) {
#ifdef _Windows
if (!Pause(buf))
bail_to_command_line();
#else
# ifdef OS2
if (strcmp(term->name, "pm") == 0 && sleep_time < 0) {
int rc;
if ((rc = PM_pause(buf)) == 0)
bail_to_command_line();
else if (rc == 2) {
fputs(buf, stderr);
text = 1;
(void) fgets(buf, MAX_LINE_LEN, stdin);
}
}
# else /* !OS2 */
# ifdef _Macintosh
if (strcmp(term->name, "macintosh") == 0 && sleep_time < 0)
Pause(sleep_time);
# else /* !_Macintosh */
# ifdef MTOS
if (strcmp(term->name, "mtos") == 0) {
int MTOS_pause(char *buf);
int rc;
if ((rc = MTOS_pause(buf)) == 0)
bail_to_command_line();
else if (rc == 2) {
fputs(buf, stderr);
text = 1;
(void) fgets(buf, MAX_LINE_LEN, stdin);
}
} else if (strcmp(term->name, "atari") == 0) {
char *readline(char *);
char *line = readline("");
if (line)
free(line);
} else
(void) fgets(buf, MAX_LINE_LEN, stdin);
# else /* !MTOS */
# ifdef ATARI
if (strcmp(term->name, "atari") == 0) {
char *readline(char *);
char *line = readline("");
if (line)
free(line);
} else
(void) fgets(buf, MAX_LINE_LEN, stdin);
# else /* !ATARI */
(void) fgets(buf, MAX_LINE_LEN, stdin);
/* Hold until CR hit. */
# endif /* !ATARI */
# endif /* !MTOS */
# endif /* !_Macintosh */
# endif /* !OS2 */
#endif
}
if (sleep_time > 0)
GP_SLEEP(sleep_time);
if (text != 0 && sleep_time >= 0)
fputc('\n', stderr);
screen_ok = FALSE;
} else if (almost_equals(c_token, "pr$int")) {
int need_space = 0; /* space printed between two expressions only */
screen_ok = FALSE;
do {
++c_token;
if (isstring(c_token)) {
char s[MAX_LINE_LEN];
quote_str(s, c_token, MAX_LINE_LEN);
fputs(s, stderr);
need_space = 0;
++c_token;
} else {
struct value a;
(void) const_express(&a);
if (need_space)
putc(' ', stderr);
need_space = 1;
disp_value(stderr, &a);
}
} while (!END_OF_COMMAND && equals(c_token, ","));
(void) putc('\n', stderr);
} else if (almost_equals(c_token, "fit")) {
++c_token;
do_fit();
} else if (almost_equals(c_token, "up$date")) {
char tmps[80];
char tmps2[80];
/* Have to initialise tmps2, otherwise
* update() cannot decide whether a valid
* filename was given. lh
*/
tmps2[0] = NUL;
if (!isstring(++c_token))
int_error("Parameter filename expected", c_token);
quote_str(tmps, c_token++, 80);
if (!(END_OF_COMMAND)) {
if (!isstring(c_token))
int_error("New parameter filename expected", c_token);
else
quote_str(tmps2, c_token++, 80);
}
update(tmps, tmps2);
} else if (almost_equals(c_token, "p$lot")) {
plot_token = c_token++;
SET_CURSOR_WAIT;
plotrequest();
SET_CURSOR_ARROW;
} else if (almost_equals(c_token, "sp$lot")) {
plot_token = c_token++;
SET_CURSOR_WAIT;
plot3drequest();
SET_CURSOR_ARROW;
} else if (almost_equals(c_token, "rep$lot")) {
if (replot_line[0] == NUL)
int_error("no previous plot", c_token);
c_token++;
SET_CURSOR_WAIT;
replotrequest();
SET_CURSOR_ARROW;
} else if (almost_equals(c_token, "se$t"))
set_command();
else if (almost_equals(c_token, "res$et"))
reset_command();
else if (almost_equals(c_token, "sh$ow"))
show_command();
else if (almost_equals(c_token, "cl$ear")) {
term_start_plot();
if (multiplot && term->fillbox) {
unsigned int x1 = (unsigned int) (xoffset * term->xmax);
unsigned int y1 = (unsigned int) (yoffset * term->ymax);
unsigned int width = (unsigned int) (xsize * term->xmax);
unsigned int height = (unsigned int) (ysize * term->ymax);
(*term->fillbox) (0, x1, y1, width, height);
}
term_end_plot();
screen_ok = FALSE;
c_token++;
} else if (almost_equals(c_token, "she$ll")) {
do_shell();
screen_ok = FALSE;
c_token++;
} else if (almost_equals(c_token, "sa$ve")) {
if (almost_equals(++c_token, "f$unctions")) {
if (!isstring(++c_token))
int_error("expecting filename", c_token);
else {
quote_str(sv_file, c_token, MAX_LINE_LEN);
save_functions(fopen(sv_file, "w"));
}
} else if (almost_equals(c_token, "v$ariables")) {
if (!isstring(++c_token))
int_error("expecting filename", c_token);
else {
quote_str(sv_file, c_token, MAX_LINE_LEN);
save_variables(fopen(sv_file, "w"));
}
} else if (almost_equals(c_token, "s$et")) {
if (!isstring(++c_token))
int_error("expecting filename", c_token);
else {
quote_str(sv_file, c_token, MAX_LINE_LEN);
save_set(fopen(sv_file, "w"));
}
} else if (isstring(c_token)) {
quote_str(sv_file, c_token, MAX_LINE_LEN);
save_all(fopen(sv_file, "w"));
} else {
int_error("filename or keyword 'functions', 'variables', or 'set' expected", c_token);
}
c_token++;
} else if (almost_equals(c_token, "l$oad")) {
if (!isstring(++c_token))
int_error("expecting filename", c_token);
else {
quote_str(sv_file, c_token, MAX_LINE_LEN);
/* load_file(fp=fopen(sv_file, "r"), sv_file, FALSE); OLD
* DBT 10/6/98 handle stdin as special case
* passes it on to load_file() so that it gets
* pushed on the stack and recusion will work, etc
*/
fp = strcmp(sv_file, "-") ? fopen(sv_file, "r") : stdin;
load_file(fp, sv_file, FALSE);
/* input_line[] and token[] now destroyed! */
c_token = num_tokens = 0;
}
} else if (almost_equals(c_token, "ca$ll")) {
if (!isstring(++c_token))
int_error("expecting filename", c_token);
else {
quote_str(sv_file, c_token, MAX_LINE_LEN);
load_file(fopen(sv_file, "r"), sv_file, TRUE); /* Argument list follows filename */
/* input_line[] and token[] now destroyed! */
c_token = num_tokens = 0;
}
} else if (almost_equals(c_token, "if")) {
double exprval;
struct value t;
if (!equals(++c_token, "(")) /* no expression */
int_error("expecting (expression)", c_token);
exprval = real(const_express(&t));
if (exprval != 0.0) {
/* fake the condition of a ';' between commands */
int eolpos = token[num_tokens - 1].start_index + token[num_tokens - 1].length;
--c_token;
token[c_token].length = 1;
token[c_token].start_index = eolpos + 2;
input_line[eolpos + 2] = ';';
input_line[eolpos + 3] = NUL;
} else
c_token = num_tokens = 0;
} else if (almost_equals(c_token, "rer$ead")) {
fp = lf_top();
if (fp != (FILE *) NULL)
rewind(fp);
c_token++;
} else if (almost_equals(c_token, "cd")) {
if (!isstring(++c_token))
int_error("expecting directory name", c_token);
else {
quote_str(sv_file, c_token, MAX_LINE_LEN);
if (changedir(sv_file)) {
int_error("Can't change to this directory", c_token);
}
c_token++;
}
} else if (almost_equals(c_token, "pwd")) {
GP_GETCWD(sv_file, sizeof(sv_file));
fprintf(stderr, "%s\n", sv_file);
c_token++;
} else if (almost_equals(c_token, "ex$it") ||
almost_equals(c_token, "q$uit")) {
/* graphics will be tidied up in main */
return (1);
} else if (!equals(c_token, ";")) { /* null statement */
#ifdef OS2
if (_osmode == OS2_MODE) {
if (token[c_token].is_token) {
int rc;
rc = ExecuteMacro(input_line + token[c_token].start_index,
token[c_token].length);
if (rc == 0) {
c_token = num_tokens = 0;
return (0);
}
}
}
#endif
int_error("invalid command", c_token);
}
return (0);
}
static pSlipObject slip_eval(pSlip gd, pSlipObject exp, pSlipEnvironment env)
{
pSlipObject proc;
pSlipObject args;
tailcall:
if (is_self_evaluating(exp) == S_TRUE)
{
return exp;
}
else if (is_variable(exp) == S_TRUE)
{
return lookup_variable_value(gd, exp, env);
}
else if (is_quoted(gd, exp) == S_TRUE)
{
return text_of_quotation(exp);
}
else if (is_assignment(gd, exp) == S_TRUE)
{
return eval_assignment(gd, exp, env);
}
else if (is_definition(gd, exp) == S_TRUE)
{
return eval_definition(gd, exp, env);
}
else if (is_if(gd, exp) == S_TRUE)
{
exp = is_true(gd, slip_eval(gd, if_predicate(exp), env)) == S_TRUE ? if_consequent(exp) : if_alternative(gd, exp);
goto tailcall;
}
else if (is_lambda(gd, exp) == S_TRUE)
{
return s_NewCompoundProc(gd, lambda_parameters(exp), lambda_body(exp), env);
}
else if (is_begin(gd, exp) == S_TRUE)
{
exp = begin_actions(exp);
while (!is_last_exp(gd, exp))
{
slip_eval(gd, first_exp(exp), env);
exp = rest_exps(exp);
}
exp = first_exp(exp);
goto tailcall;
}
else if (is_cond(gd, exp) == S_TRUE)
{
exp = cond_to_if(gd, exp);
goto tailcall;
}
else if (is_let(gd, exp) == S_TRUE)
{
exp = let_to_application(gd, exp);
goto tailcall;
}
else if (is_application(exp) == S_TRUE)
{
proc = slip_eval(gd, slip_operator(exp), env);
if (proc == NULL)
return gd->singleton_False;
if (proc->type == eType_PRIMITIVE_PROC || proc->type == eType_COMPOUND_PROC)
{
args = list_of_values(gd, operands(exp), env);
if (args == NULL)
return gd->singleton_False;
if (sIsObject_PrimitiveProc(proc) == S_TRUE)
{
return proc->data.prim_proc.func(gd, args);
}
else if (sIsObject_CompoundProc(proc) == S_TRUE)
{
env = setup_environment(gd, proc->data.comp_proc.env, proc->data.comp_proc.params, args);
exp = make_begin(gd, proc->data.comp_proc.code);
goto tailcall;
}
else
{
throw_error(gd, "unknown procedure type\n");
return gd->singleton_False;
}
}
else
return proc;
}
else
{
throw_error(gd, "cannot eval unknown expression type\n");
return NULL;
}
throw_error(gd, "what??\n");
return NULL;
}
expr const & declaration::get_value() const { lean_assert(is_definition()); return *(m_ptr->m_value); }
bool declaration::is_theorem() const { return is_definition() && m_ptr->m_theorem; }
bool declaration::is_constant_assumption() const { return !is_definition(); }
///////////////////////////////////////////////////////////////////
//eval
//requires two arguments:exp & tail_context
///////////////////////////////////////////////////////////////////
cellpoint eval(void)
{
if (is_true(is_self_evaluating(args_ref(1)))){
reg = args_ref(1);
}else if (is_true(is_variable(args_ref(1)))){
reg = args_ref(1);
args_push(current_env);
args_push(reg);
reg = lookup_var_val();
}else if (is_true(is_quoted(args_ref(1)))){
args_push(args_ref(1));
reg = quotation_text();
}else if (is_true(is_assignment(args_ref(1)))){
args_push(args_ref(1));
reg = eval_assignment();
}else if (is_true(is_definition(args_ref(1)))){
args_push(args_ref(1));
reg = eval_definition();
}else if (is_true(is_if(args_ref(1)))){
//eval if expression with the second argument (tail_context)
reg = args_ref(1);
args_push(args_ref(2));
args_push(reg);
reg = eval_if();
}else if (is_true(is_lambda(args_ref(1)))){
args_push(args_ref(1));
reg = eval_lambda();
}else if (is_true(is_begin(args_ref(1)))){
args_push(args_ref(1));
reg = begin_actions();
//eval the actions of begin exp with the second argument (tail_context)
args_push(args_ref(2));
args_push(reg);
reg = eval_sequence();
}else if (is_true(is_cond(args_ref(1)))){
args_push(args_ref(1));
reg = cond_2_if();
//eval the exp with the second argument (tail_context)
args_push(args_ref(2));
args_push(reg);
reg = eval();
}else if (is_true(is_and(args_ref(1)))){
reg = args_ref(1);
args_push(args_ref(2));
args_push(reg);
reg = eval_and();
}else if (is_true(is_or(args_ref(1)))){
reg = args_ref(1);
args_push(args_ref(2));
args_push(reg);
reg = eval_or();
}else if (is_true(is_let(args_ref(1)))){
//convert let to combination
args_push(args_ref(1));
reg = let_2_combination();
//evals the combination
args_push(args_ref(2));
args_push(reg);
reg = eval();
}else if (is_true(is_letstar(args_ref(1)))){
//convert let* to nested lets
args_push(args_ref(1));
reg = letstar_2_nested_lets();
//evals the nested lets
args_push(args_ref(2));
args_push(reg);
reg = eval();
}else if (is_true(is_application(args_ref(1)))){
//computes operator
args_push(args_ref(1));
reg = operator();
args_push(a_false);
args_push(reg);
reg = eval();
stack_push(&vars_stack, reg);
//computes operands
args_push(args_ref(1));
reg = operands();
args_push(reg);
reg = list_of_values();
//calls apply with the second argument (tail_context)
args_push(args_ref(2));
args_push(reg);
args_push(stack_pop(&vars_stack));
reg = apply();
}else {
printf("Unknown expression type -- EVAL\n");
error_handler();
}
args_pop(2);
return reg;
}
