/* compose -- evaluate a sequential composition or piping */
PRIVATE env compose(tree t, env e, tok ldec, tok rdec, char *kind)
{
env e1 = tc_sexp(t->x_arg1, e);
env e2 = tc_sexp(t->x_arg2, e);
env ee = new_env(e);
def q;
/* Get vars from left arg that don't match */
for (;;) {
def d = pop_def(e1);
if (d == NULL)
break;
else if (d->d_name->s_decor != ldec)
push_def(d, ee);
else {
sym rname = mk_symbol(d->d_name->s_basename, rdec);
type rtype = del_var(rname, e2);
if (rtype == NULL)
push_def(d, ee);
else if (! unify(d->d_type, rtype)) {
tc_error(t->x_loc, "Type mismatch in %s", kind);
tc_e_etc("Expression: %z", t);
tc_e_etc("Type of %n in LHS: %t", d->d_name, d->d_type);
tc_e_etc("Type of %n in RHS: %t", rname, rtype);
tc_e_end();
}
}
}
/* Now merge the unmatched vars from the right */
for (q = e2->e_defs; q != NULL; q = q->d_next)
merge_def(VAR, q->d_name, q->d_type, ee, t, t->x_loc);
return ee;
}
pointer seld_notes() {
amc_found=tst_alive_amc();
if (!amc_found && !find_amc())
return Error_0("STOP! amc not running");
BMessage mes(STORE_SEL),
reply;
StoredNote *notes;
Settings *settings;
ssize_t bytes=0;
int n,
items=0;
amc_application.SendMessage(&mes,&reply);
puts("amc did reply");
switch (reply.what) {
case CONTENTS_SEL:
reply.FindData(SELD_NOTES,B_OBJECT_TYPE,(const void**)(¬es),&bytes);
items=bytes/sizeof(StoredNote);
reply.FindData(SETTINGS,B_OBJECT_TYPE,(const void**)(&settings),&bytes);
break;
default: return Error_0("seld notes: unknown reply");
}
pointer ptr,
out=nil_pointer();
for (n=0;n<items;++n) {
ptr=cons(mk_integer(notes[n].lnr),
cons(mk_integer(notes[n].snr),
cons(mk_integer(notes[n].sign),
cons(mk_integer(notes[n].dur),nil_pointer()))));
out=cons(ptr,out);
}
ptr=cons(mk_integer(settings->meter),nil_pointer());
ptr=cons(mk_symbol("meter"),ptr);
ptr=cons(ptr,nil_pointer());
return cons(ptr,out);
}
void Theme::init_interpreter(void) {
if(priv->sc) return;
scheme *ss = edelib_scheme_init_raw();
if(!ss) {
E_WARNING(E_STRLOC ": Unable to init interpreter\n");
return;
}
priv->sc = ss;
/* must be called */
scheme_set_input_port_file(ss, stdin);
scheme_set_output_port_file(ss, stdout);
/* install user supplied error handler first, if given */
if(priv->err_func) {
ss->vptr->scheme_define(ss,
ss->global_env,
ss->vptr->mk_symbol(ss, "private:theme.error_hook"),
ss->vptr->mk_foreign_func(ss, theme_error_hook));
/* make sure interpreter does not use this function at all */
scheme_set_external_data(ss, (void*)priv);
}
/* load init stuff */
scheme_load_string(ss, init_ss_content);
/* load theme stuff */
scheme_load_string(ss, theme_ss_content);
/*
* Set (or override) common variables before actual script was loaded.
* Variables are static and can't be changed.
*/
pointer sym;
sym = mk_symbol(ss, "*edelib-dir-separator*");
scheme_define(ss, ss->global_env, sym, mk_string(ss, E_DIR_SEPARATOR_STR));
ss->vptr->setimmutable(sym);
sym = mk_symbol(ss, "*edelib-version*");
scheme_define(ss, ss->global_env, sym, mk_string(ss, EDELIB_VERSION));
ss->vptr->setimmutable(sym);
}
static char *get_string_var(scheme *sc, const char *symbol) {
pointer x = edelib_scheme_eval(sc, mk_symbol(sc, symbol));
if(x != sc->NIL && sc->vptr->is_string(x))
return sc->vptr->string_value(x);
return NULL;
}
static void dopending(Symbol p) {
if (pending != NULL) {
int uid = symboluid(pending);
rcc_symbol_ty symbol = mk_symbol(pending);
Seq_addhi(pickle->items, rcc_Symbol(uid, symbol));
}
pending = p;
}
static void asdl_local(Symbol p) {
assert(p->x.offset == 0);
put(rcc_Local(symboluid(p), mk_symbol(p)));
if (p->temporary && p->u.t.cse) {
p->u.t.next = temps;
temps = p;
}
}
jl_sym_t *jl_symbol(const char *str)
{
jl_sym_t **pnode;
pnode = symtab_lookup(&symtab, str);
if (*pnode == NULL)
*pnode = mk_symbol(str);
return *pnode;
}
/* open_sref -- find a schema and process its parameters */
PUBLIC bool open_sref(tree t, env e, def *d, frame *f)
{
if ((*d = get_schema((tok) t->x_sref_tag, t->x_loc)) == NULL)
return FALSE;
*f = mk_frame((*d)->d_nparams);
get_params("Schema", mk_symbol((tok) t->x_sref_tag, empty),
t->x_sref_params, e, *f, t->x_loc);
return TRUE;
}
value_t symbol(char *str)
{
symbol_t **pnode;
pnode = symtab_lookup(&symtab, str);
if (*pnode == NULL)
*pnode = mk_symbol(str);
return tagptr(*pnode, TAG_SYM);
}
bool Theme::load(const char *f) {
E_RETURN_VAL_IF_FAIL(f != NULL, false);
/* do not allow loading if clear() wasn't called before */
E_RETURN_VAL_IF_FAIL(priv->sc == NULL, false);
priv->is_loaded = false;
init_interpreter();
scheme *ss = priv->sc;
/*
* Determine from which directory we loads file, and set that file as base directory
* where '(include)' statement can search additional files. Include uses 'private::theme.search-path'.
*/
char *path = edelib_strndup(f, PATH_MAX);
if(!path)
E_FATAL(E_STRLOC ": No memory\n");
char *dir = local_dirname(path);
/* If returned name is the same as file, dirname wasn't found directory name in given path. */
if(strcmp(dir, f) != 0) {
pointer sym = mk_symbol(ss, "private:theme.search-path");
edelib_scheme_define(ss, ss->global_env, sym, mk_string(ss, dir));
ss->vptr->setimmutable(sym);
}
/* scheme copies path, so we do not need it any more */
free(path);
FILE *fd = fopen(f, "r");
if(!fd) {
edelib_scheme_deinit(ss);
free(ss);
priv->sc = 0;
return false;
}
edelib_scheme_load_named_file(ss, fd, f);
fclose(fd);
if(ss->no_memory) {
E_WARNING(E_STRLOC ": No memory to load theme source in interpreter\n");
return false;
}
if(ss->retcode != 0)
return false;
/* fetch common variables */
priv->name = get_string_var(ss, "private:theme.name");
priv->author = get_string_var(ss, "private:theme.author");
priv->sample = get_string_var(ss, "private:theme.sample");
priv->is_loaded = true;
return true;
}
static jl_sym_t *_jl_symbol(const char *str, size_t len)
{
jl_sym_t **pnode;
jl_sym_t *parent;
pnode = symtab_lookup(&symtab, str, len, &parent);
if (*pnode == NULL) {
*pnode = mk_symbol(str, len);
if (parent != NULL)
jl_gc_wb(parent, *pnode);
}
return *pnode;
}
jl_sym_t *jl_symbol(const char *str)
{
jl_sym_t **pnode;
jl_sym_t *parent;
pnode = symtab_lookup(&symtab, str, &parent);
if (*pnode == NULL) {
*pnode = mk_symbol(str);
if (parent != NULL)
gc_wb(parent, *pnode);
}
return *pnode;
}
static jl_sym_t *_jl_symbol(const char *str, size_t len)
{
jl_sym_t *volatile *slot;
jl_sym_t *node = symtab_lookup(&symtab, str, len, &slot);
if (node == NULL) {
JL_LOCK(&symbol_table_lock); // Might GC
// Someone might have updated it, check and look up again
if (*slot != NULL && (node = symtab_lookup(slot, str, len, &slot))) {
JL_UNLOCK(&symbol_table_lock); // Might GC
return node;
}
node = mk_symbol(str, len);
jl_atomic_store_release(slot, node);
JL_UNLOCK(&symbol_table_lock); // Might GC
}
return node;
}
static enum TOK_T get_next_token(port *in, pointer *token)
{
char ch, *t;
skip_white_spc(in);
switch (ch = get_next_char(in)) {
case EOF:
return FILE_END;
case '(':
return LIST_START;
case ')':
return LIST_END;
case '"':
*token = mk_string(read_string(in));
return STRING;
case '\'':
return QUOTE;
case '`':
return BACKQUOTE;
case ',':
if ((ch = get_next_char(in)) == '@')
return SPLICE;
else {
push_back_char(in, ch);
return UNQUOTE;
}
case '.':
return DOT;
default:
push_back_char(in, ch);
t = get_char_until_delim(in);
if (test_number(t)) {
*token = mk_number(atoi(t));
return NUMBER;
} else {
*token = mk_symbol(t);
return SYMBOL;
}
}
}
ShellService::ShellService()
: d(new Impl)
{
if (d->m_Scheme == nullptr)
{
throw std::runtime_error("Could not initialize Scheme interpreter");
}
scheme_set_output_port_file(d->m_Scheme, stdout);
BundleResource schemeInitRes = GetBundleContext().GetBundle().GetResource("tinyscheme/init.scm");
if (schemeInitRes)
{
this->LoadSchemeResource(schemeInitRes);
}
else
{
std::cerr << "Scheme file init.scm not found";
}
std::vector<BundleResource> schemeResources = GetBundleContext().GetBundle().FindResources("/", "*.scm", false);
for (std::vector<BundleResource>::iterator iter = schemeResources.begin(),
iterEnd = schemeResources.end(); iter != iterEnd; ++iter)
{
if (*iter)
{
this->LoadSchemeResource(*iter);
}
}
scheme_define(d->m_Scheme, d->m_Scheme->global_env, mk_symbol(d->m_Scheme, "us-bundle-ids"), mk_foreign_func(d->m_Scheme, us_bundle_ids));
scheme_define(d->m_Scheme, d->m_Scheme->global_env, mk_symbol(d->m_Scheme, "us-bundle-info"), mk_foreign_func(d->m_Scheme, us_bundle_info));
scheme_define(d->m_Scheme, d->m_Scheme->global_env, mk_symbol(d->m_Scheme, "us-display-bundle-info"), mk_foreign_func(d->m_Scheme, us_display_bundle_info));
scheme_define(d->m_Scheme, d->m_Scheme->global_env, mk_symbol(d->m_Scheme, "us-bundle-start"), mk_foreign_func(d->m_Scheme, us_bundle_start));
scheme_define(d->m_Scheme, d->m_Scheme->global_env, mk_symbol(d->m_Scheme, "us-bundle-stop"), mk_foreign_func(d->m_Scheme, us_bundle_stop));
scheme_define(d->m_Scheme, d->m_Scheme->global_env, mk_symbol(d->m_Scheme, "us-install"), mk_foreign_func(d->m_Scheme, us_install));
}
void init_plugin(scheme *sc)
{
scheme_define(sc, sc->global_env,
mk_symbol(sc, "plugin"),
mk_foreign_func(sc, plugin_function));
}
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;
}
int main(int argc, char **argv)
{
scheme sc;
FILE *fin;
char *file_name = INITFILE;
int isfile = 1;
if (argc == 1) {
printf(BANNER);
}
if (argc == 2 && strcmp(argv[1], "-?") == 0) {
usage();
return 1;
}
if (!scheme_init(&sc)) {
fprintf(stderr, "Could not initialize!\n");
return 2;
}
scheme_set_input_port_file(&sc, stdin);
scheme_set_output_port_file(&sc, stdout);
#if USE_DL
scheme_define(&sc, sc.global_env,
mk_symbol(&sc, "load-extension"),
mk_foreign_func(&sc, scm_load_ext));
#endif
argv++;
if (access(file_name, 0) != 0) {
char *p = getenv("TINYSCHEMEINIT");
if (p != 0) {
file_name = p;
}
}
do {
if (strcmp(file_name, "-") == 0) {
fin = stdin;
} else if (strcmp(file_name, "-1") == 0 ||
strcmp(file_name, "-c") == 0) {
pointer args = sc.NIL;
isfile = file_name[1] == '1';
file_name = *argv++;
if (strcmp(file_name, "-") == 0) {
fin = stdin;
} else if (isfile) {
fin = fopen(file_name, "r");
}
for (; *argv; argv++) {
pointer value = mk_string(&sc, *argv);
args = cons(&sc, value, args);
}
args = reverse_in_place(&sc, sc.NIL, args);
scheme_define(&sc, sc.global_env,
mk_symbol(&sc, "*args*"), args);
} else {
fin = fopen(file_name, "r");
}
if (isfile && fin == 0) {
fprintf(stderr, "Could not open file %s\n", file_name);
} else {
if (isfile) {
scheme_load_named_file(&sc, fin, file_name);
} else {
scheme_load_string(&sc, file_name);
}
if (!isfile || fin != stdin) {
if (sc.retcode != 0) {
fprintf(stderr, "Errors encountered reading %s\n", file_name);
}
if (isfile) {
fclose(fin);
}
}
}
file_name = *argv++;
} while (file_name != 0);
if (argc == 1) {
scheme_load_named_file(&sc, stdin, 0);
}
scheme_deinit(&sc);
return sc.retcode;
}
static void asdl_address(Symbol q, Symbol p, long n) {
assert(q->x.offset == 0);
put(rcc_Address(symboluid(q), mk_symbol(q), symboluid(p), n));
}
static pointer cons_with_symbol(char *string, pointer object)
{
return cons(mk_symbol(string), object);
}
