Scheme_Object *scheme_sfs(Scheme_Object *o, SFS_Info *info, int max_let_depth)
{
int init, i;
SFS_LOG(printf("sfs %d\n", SCHEME_TYPE(o)));
if (!info) {
info = scheme_new_sfs_info(max_let_depth);
}
info->pass = 0;
info->ip = 1;
info->abs_ip = 1;
info->saved = scheme_null;
info->min_touch = -1;
info->max_touch = -1;
info->tail_pos = 1;
init = info->stackpos;
o = scheme_sfs_expr(o, info, -1);
if (info->seqn)
scheme_signal_error("ended in the middle of an expression?");
# if MAX_SFS_CLEARING
info->max_nontail = info->ip;
info->abs_max_nontail = info->abs_ip;
# endif
for (i = info->depth; i-- > init; ) {
info->max_calls[i] = info->max_nontail;
}
{
Scheme_Object *v;
v = scheme_reverse(info->saved);
info->saved = v;
}
info->pass = 1;
info->seqn = 0;
info->ip = 1;
info->abs_ip = 1;
info->tail_pos = 1;
info->stackpos = init;
o = scheme_sfs_expr(o, info, -1);
return o;
}
static Scheme_Object *do_define_syntaxes_clone(Scheme_Object *expr, int jit)
{
Resolve_Prefix *rp, *orig_rp;
Scheme_Object *naya, *rhs;
rhs = SCHEME_VEC_ELS(expr)[0];
#ifdef MZ_USE_JIT
if (jit) {
if (SAME_TYPE(SCHEME_TYPE(expr), scheme_define_syntaxes_type))
naya = scheme_jit_expr(rhs);
else {
int changed = 0;
Scheme_Object *a, *l = rhs;
naya = scheme_null;
while (!SCHEME_NULLP(l)) {
a = scheme_jit_expr(SCHEME_CAR(l));
if (!SAME_OBJ(a, SCHEME_CAR(l)))
changed = 1;
naya = scheme_make_pair(a, naya);
l = SCHEME_CDR(l);
}
if (changed)
naya = scheme_reverse(naya);
else
naya = rhs;
}
} else
#endif
naya = rhs;
orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1];
rp = scheme_prefix_eval_clone(orig_rp);
if (SAME_OBJ(naya, rhs)
&& SAME_OBJ(orig_rp, rp))
return expr;
else {
expr = scheme_clone_vector(expr, 0, 1);
SCHEME_VEC_ELS(expr)[0] = naya;
SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp;
return expr;
}
}
/*
* (getenv <what>) => <string>
* returns environment value for <what>; if <what> is not given, returns a list of all environment key/value pairs
*/
static pointer s_getenv(scheme* sc, pointer arg) {
if(arg == sc->NIL) {
char** env = environ;
pointer lst = sc->NIL;
while(*env) {
lst = cons(sc, mk_string(sc, *env), lst);
env++;
}
return scheme_reverse(sc, lst);
}
pointer a = sc->vptr->pair_car(arg);
if(a != sc->NIL && sc->vptr->is_string(a)) {
const char* val;
if((val = getenv(sc->vptr->string_value(a))) != NULL)
return mk_string(sc, val);
}
return sc->F;
}
/* (exec cmd) => (output list) */
static pointer s_exec(scheme* sc, pointer args) {
if(args == sc->NIL)
return sc->F;
pointer a = sc->vptr->pair_car(args);
if(a == sc->NIL || !sc->vptr->is_string(a)) {
/* TODO: this should be an error */
return sc->F;
}
const char *cmd = sc->vptr->string_value(a);
FILE *fd = popen(cmd, "r");
if(!fd)
return sc->F;
pointer lst = sc->NIL;
char buf[256];
int len;
while(fgets(buf, sizeof(buf), fd)) {
len = strlen(buf);
/* remove appended newline */
if(len > 1 && buf[len - 1] == '\n') {
buf[len - 1] = '\0';
len--;
} else {
/* do not append empty lines or possible newlines */
continue;
}
lst = cons(sc, mk_counted_string(sc, buf, len), lst);
}
pclose(fd);
return scheme_reverse(sc, lst);
}
int main(int argc, char **argv) {
FILE *fin = NULL;
const char *expr = NULL;
scheme sc;
if(argc > 1) {
if(argv[1][0] == '-') {
if((strcmp(argv[1], "--help") == 0) || (strcmp(argv[1], "-h") == 0)) {
help();
return 0;
} else if((strcmp(argv[1], "--expression") == 0) || (strcmp(argv[1], "-e") == 0)) {
if(!argv[2]) {
printf("This option requires a parameter\n");
return 1;
}
expr = argv[2];
} else {
printf("Unrecognized option. Use 'ede-scriptbus --help' for options\n");
return 1;
}
}
if(!expr) {
fin = fopen(argv[1], "r");
if(!fin) {
fprintf(stderr, "Unable to load '%s' file!\n", argv[1]);
return 1;
}
}
}
if(!scheme_init(&sc)) {
fprintf(stderr, "Fatal: Unable to initialize interpreter!\n");
return 1;
}
scheme_set_input_port_file(&sc, stdin);
scheme_set_output_port_file(&sc, stdout);
/* load basic stuff */
scheme_load_string(&sc, init_scm_content);
/* register additional functions */
register_sys_functions(&sc);
register_communication_functions(&sc);
register_string_functions(&sc);
register_wm_functions(&sc);
/* construct *args* */
pointer args = sc.NIL;
for(int i = 0; i < argc; i++) {
pointer value = mk_string(&sc, argv[i]);
args = cons(&sc, value, args);
}
args = scheme_reverse(&sc, args);
scheme_define(&sc, sc.global_env, mk_symbol(&sc, "*args*"), args);
if(!expr) {
/* load file or go into console */
if(!fin) {
fin = stdin;
printf("Type '(quit)' or press Ctrl-D to quit");
}
scheme_load_file(&sc, fin);
} else {
/* or execute expression */
scheme_load_string(&sc, expr);
if(sc.retcode != 0)
printf("Bad expression: '%s'\n", expr);
}
scheme_deinit(&sc);
return 0;
}
