#include "m_pd.h" #include #include #include #include /* TODO: make allot check forth size, and use realloc */ /* yet another forth. this time: a traditional idt forth * float (+ * - / < > = >= <=) and int (add mul sub div mod and or xor lt gt eq gte lte) * symbols, no strings input: pd messages many thanks to Brad Rodriguez for "MOVING FORTH", a series of articles on building a forth which can be found at http://www.zetetics.com/bj/papers/moving1.htm */ /* some GNU style pedantery */ #define symbol_t t_symbol #define object_t t_object #define class_t t_class #define method_t t_method #define newmethod_t t_newmethod #define symbol_t t_symbol #define atom_t t_atom #define outlet_t t_outlet #define inlet_t t_inlet #define signal_t t_signal #define canvas_t t_canvas #define clock_t t_clock #define garray_t t_garray #define atomtype_t t_atomtype #define pd_t t_pd typedef struct link_ link_t; typedef void **xt_t; // execution token, points to code field typedef xt_t *thread_t; // a thread is an array of excuction tokens #define NUMBER_FLOAT 0 #define NUMBER_INT 1 typedef int cell_t; // basic cell is default machine word struct link_{ link_t *prev; // previous link record symbol_t *name; // word symbol xt_t compile; // xt of compiling word (i.e. compile, execute, ...) }; /* the parameter field address (pfa) is normally cfa + 1 cell except for words created with 'create .. does>' reading brad's article there are 2 adopted solutions for this (1) an extra cell in a highlevel word to point to the pfa of the shared code (2) a solution involving a naked machine code stub i can't do (2) here without introducing portability issues (the reason i use compute gotos in the first place) and i don't like (1), because it breaks the uniformity of cf/pf structure so i go for one extra cell in the link. this means all words have one extra cell in their definition, but we're not directly targetting small machines here.. */ typedef struct forthsys_ forthsys_t; #define INNER_TRACE (1<<0) // enable NEXT trace #define OUTER_TRACE (1<<1) // enable interpreter trace /* system block containing 32 system registers this is the bottom of the dictionary wrapped in a structure for convenience */ struct forthsys_ { /* forth */ link_t s; // sentinel link points to last link (child dictionaries point to sentinel) cell_t *dst; // top of data stack pointer cell_t *rst; // return stack cell_t *free; // top of allot stack pointer (dictionary free) void ***ip; // ->->next instruction int state; // interpreter state int number; // current number type int forth_cells; // nb of cells in forth (for allot) forthsys_t *active; // points to active forth (i.o.w.: current namespace pointer) /* io */ int argc; // number of input atoms atom_t *argv; // input atoms /* dsp */ int signal_inlets; int signal_outlets; int n; /* debug */ int debug_flags; }; #define DEFAULT_DST 64 #define DEFAULT_RST 80 #define DEFAULT_FREE 80 // first free cell in dictionary #define DEFAULT_PORTS 32 // dsp port registers /* cache lines size is 64 bytes for most current archs, one cache line each (16 words) is reserved for data stack and return stack the system registers get one 2 cache lines, the port vectors get 1 cache line 00-31: sentinel link and system registers 32-47: port vectors 48-63: data stack 64-79: return stack the forth's input consists of pd messages (atom arrays) */ /* unix stuff */ // if this value is nonzero, the jump buffer is valid static volatile int running_forth = 0; #ifdef __unix__ #include #include #include int caught_signal = 0; sigjmp_buf longjmp_signal; static void sig(int n){ if (running_forth){ caught_signal = n; siglongjmp(longjmp_signal, -1); } else { post("MOLE: got signal %d outside of interpreter (pid = %d). exiting pd.", n, getpid()); pd_typedmess(gensym("pd")->s_thing, gensym("quit"), 0, 0); } } static void install_signal_handler(int signal, void (*handler)(int)) { struct sigaction sa; sa.sa_flags = 0; sa.sa_handler = handler; memset(&sa.sa_mask, 0, sizeof(sa.sa_mask)); sa.sa_restorer = 0; if (sigaction(signal, &sa, 0) < 0) post("Can't set signal %d handler.", signal); } static void setup_unix(void){ post("MOLE: installing signal handlers"); install_signal_handler(SIGINT, sig); install_signal_handler(SIGSEGV, sig); install_signal_handler(SIGFPE, sig); } #endif #define MAX_NB_PORT 8 /* pd object */ typedef struct mole_ { object_t obj; float dc; // signal dc value forthsys_t *f; // private forth dictionary (actually cell_t array, but cast as system block) symbol_t *name; // source code module name canvas_t *canvas; clock_t *clock; outlet_t *outlet[MAX_NB_PORT]; inlet_t *inlet[MAX_NB_PORT]; int nb_outlets; int nb_inlets; } mole_t; /* mole methods */ static int run_forth(mole_t *x); // transfer code to mole's forth + helper routines static int mole_load(mole_t *x, symbol_t *s); // load a source module into mole's forth static void mole_init(mole_t *x); // (re)initialize a mole's forth static void mole_reset(mole_t *x); // clear and reload mole's forth static void mole_send_pd_message(mole_t *x, atom_t *a); // send a zero terminated message static int mole_new_inlet(mole_t *x, symbol_t *from, symbol_t *to); static int mole_new_outlet(mole_t *x, symbol_t *type); /* queue object. the buffer is located before the struct. */ typedef struct queue_{ unsigned int mask; unsigned int read_index; unsigned int write_index; } queue_t; inline static cell_t queue_read(queue_t *x){ cell_t c = ((cell_t *)x)[(x->read_index)++]; x->read_index |= x->mask; // or mask : we use negative indices return c; } inline static void queue_write(queue_t *x, cell_t c){ ((cell_t *)x)[(x->write_index)++] = c; x->write_index |= x->mask; // or mask : we use negative indices } inline static unsigned int queue_elements(queue_t *x){ return ((x->write_index - x->read_index) & (~x->mask)); } static void register_mole(mole_t *x){ pd_bind((pd_t *)x, gensym("mole.broadcast")); } static void unregister_mole(mole_t *x){ pd_unbind((pd_t *)x, gensym("mole.broadcast")); } /* on REBOOT (reloading of main forth) all children need to be re-initialized to remove dangling references. */ static void broadcast_children(symbol_t *selector, int argc, atom_t *argv){ pd_t *thing = gensym("mole.broadcast")->s_thing; if (!thing) return; // no children startpost("MOLE: broadcast %s", selector->s_name); postatom(argc, argv); endpost(); pd_typedmess(thing, selector, argc, argv); } /* global forth */ #define FORTH_CELLS 0x8000 // global forth's size cell_t *global_forth; static mole_t global_mole; // dummy pd object for global forth. DO NOT USE PD CALLS IN MAIN SETUP CODE!!! thread_t interpreter = 0; // address of interpreter loop thread (0 triggers a main REBOOT) static int initialized = 0; class_t *mole_class; /* DICTIONARY */ // trim unused cells static void trim(forthsys_t *f){ forthsys_t *f_new; f->forth_cells = f->free - ((cell_t *)f); f_new = realloc(f, sizeof(cell_t) * f->forth_cells); if (f != f_new){ post("fatal error: forth trim failed"); exit(1); } } // yeah, too bad, but all linear memory allocation (changing f->free) // has to pass through this call static cell_t* allot(forthsys_t *f, int bytes){ int cells = ((bytes-1) / sizeof(cell_t)) + 1; // align to cell size cell_t *current = f->free; cell_t *next = current + cells; cell_t *start = (cell_t *)f; cell_t *new_start; // check if we need to realloc if ((next - start) > f->forth_cells){ f->forth_cells *= 2; // double memory usage post("doubling forth size to %d cells", f->forth_cells); new_start = realloc(start, sizeof(cell_t) * f->forth_cells); if (new_start != start){ post("fatal error: can't grow forth"); exit(1); } } // update and return f->free += cells; return current; } // add a word to a forth static link_t *add_link(forthsys_t *f, symbol_t *s){ link_t *newlink = (link_t *)allot(f, sizeof(link_t)); newlink->name = s; newlink->prev = f->s.prev; // insert between last and sentinel newlink->compile = 0; f->s.prev = newlink; return newlink; } // print words in a link chain static void file_link(link_t *lst, FILE *f, char *separator, char *endmarker){ if (!separator) separator = " "; if (!endmarker) endmarker = "\n"; while (lst){ fprintf(f, "%s%s", lst->name->s_name, separator); lst = lst->prev;} fprintf(f, endmarker); } static void print_link(link_t *lst){ file_link(lst, stderr, " ", "\n"); } // save words in a linkt to a file static void save_link(link_t *lst, char *filename){ FILE *f = fopen(filename, "w"); file_link(lst, f, " ", "\n"); fclose(f); } // lookup word in a link // return execution token static xt_t lookup(link_t *lst, symbol_t *s){ while(lst){ if (lst->name == s){return (xt_t)(lst+1);} //return cfa (cf is located just after link struct) lst = lst->prev; } return 0; } static void init_forth(forthsys_t *f, forthsys_t *p, symbol_t *name) { cell_t *forth = (cell_t *)f; /* initialize system variables */ f->dst = forth + DEFAULT_DST; f->rst = forth + DEFAULT_RST; f->free = forth + DEFAULT_FREE; f->state = 0; f->debug_flags = 0; f->number = NUMBER_FLOAT; f->active = f; // active dictionary is self f->argc = 0; f->argv = 0; /* setup 'outer' dictionary link in sentinel */ f->s.prev = &p->s; // my top = by bottom = parent's sentinel f->s.name = name; // start forth interpreter on next entry f->ip = interpreter; } typedef void (*vc_0)(void); typedef void (*vc_1)(cell_t); /* helper functions stuff that needs to be done outside of forth stack frame to enable full independence of c-stack */ /* execute a routine outside of stacframe and return */ #define YIELD_C 1 /* error messages */ #define ERROR_INPUT -1 #define ERROR_UNDEF -2 #define ERROR_TYPE -3 #define ERROR_THREAD -4 #define ERROR_SIGNAL -5 /* FORTH an indirect threaded forth implemented using computed goto. executing this functions resumes the virtual machine's execution. the function returns an error code: zero = OK positive = upstream message (i.e. YIELD_C) negative = fatal error */ /* xt cache */ xt_t xt_compile; xt_t xt_execute; xt_t xt_leave; xt_t xt_lit; /* forth words called outside forth stack frame */ #define POP_DS(f) (*(f->dst)++) #define PUSH_DS(f) (*--(f->dst)) typedef void (*mole_method_t)(mole_t *); static void c_mole_pd_free(mole_t *x){ pd_t *thing = (pd_t *)POP_DS(x->f); //post("MOLE: freeing pd object %x", thing); if (thing) {pd_free(thing);} } void obj_connect(object_t *, int, object_t *, int); void obj_disconnect(object_t *, int, object_t *, int); static void c_mole_pd_connect(mole_t *x){ int dst_n = (int) POP_DS(x->f); object_t *dst_o = (object_t *) POP_DS(x->f); int src_n = (int) POP_DS(x->f); object_t *src_o = (object_t *) POP_DS(x->f); if (src_o && dst_o) obj_connect(src_o, src_n, dst_o, dst_n); } static void c_mole_pd_disconnect(mole_t *x){ int dst_n = (int) POP_DS(x->f); object_t *dst_o = (object_t *) POP_DS(x->f); int src_n = (int) POP_DS(x->f); object_t *src_o = (object_t *) POP_DS(x->f); if (src_o && dst_o) obj_disconnect(src_o, src_n, dst_o, dst_n); } static void c_mole_load(mole_t *x){ int e; symbol_t *s = (symbol_t *)POP_DS(x->f); if (e = mole_load(x, s)){ // what to do when load fails? //post("MOLE: failed to load %s", s->s_name); } } static void c_mole_send(mole_t *x){mole_send_pd_message(x, (atom_t*)POP_DS(x->f));} static void c_mole_new_inlet(mole_t *x){ symbol_t *to = (symbol_t *)POP_DS(x->f); symbol_t *from = (symbol_t *)POP_DS(x->f); PUSH_DS(x->f) = (cell_t)mole_new_inlet(x, to, from); } static void c_mole_new_outlet(mole_t *x){ PUSH_DS(x->f) = (cell_t)mole_new_outlet(x, (symbol_t *)POP_DS(x->f)); } // create a new inlet or reuse an old one (i.e. when forth is rebooted) int mole_new_inlet(mole_t *x, symbol_t *from, symbol_t *to){ int i = x->nb_inlets++; if (!x->inlet[i]){ // reuse if possible x->inlet[i] = inlet_new(&x->obj, &x->obj.ob_pd, from, to); if ((from == to) && (from == &s_signal)) x->f->signal_inlets++; } return i; } int mole_new_outlet(mole_t *x, symbol_t *type){ int i = x->nb_outlets++; if (!x->outlet[i]){ // reuse if possible x->outlet[i] = outlet_new(&x->obj, type); } return i; } static int enter_forth(mole_t *x) { /* some convenience macros */ //#define NEXT {goto next;} #define NEXT {current = *ip++; goto **current;} #define DS_POP (*dst++) #define DS_PUSH (*--dst) #define DS_TOP (dst[0]) #define DS_2ND (dst[1]) #define UNDO_DS_POP dst-- #define RS_POP (*rst++) #define RS_PUSH (*--rst) #define RS_TOP (rst[0]) #define RS_2ND (rst[1]) #define PRIM(name, label) label: #define SENTINEL f->active->s #define COMPILE(thing) {*allot(f->active, sizeof(cell_t)) = (cell_t)(thing);} #define LOOKUP(sym) lookup(SENTINEL.prev, (sym)) #define SCOMPILE(sym) COMPILE(LOOKUP(sym)) #define WCOMPILE(name) SCOMPILE(gensym(name)) #define XT2LINK(xt) (((link_t *)xt)-1) #define SETIMMEDIATE(name){XT2LINK(LOOKUP(gensym(name)))->compile = xt_execute;} /* read an atom from input stream */ #define ACCEPT { \ if (f->argc){ \ atom = (f->argv)++; \ (f->argc)--; \ if (f->debug_flags & OUTER_TRACE){ \ fprintf(stderr, "I>"); \ postatom(1, atom); \ post(""); \ } \ DS_PUSH = atom->a_w.w_index; \ DS_PUSH = atom->a_type; \ } \ else {DS_PUSH = 0; DS_PUSH = 0;} /* end of input */ \ } /* problem with trace in combination with postpone */ #define DOTRACE(current){ \ if (f->debug_flags & INNER_TRACE){ \ int depth = (cell_t *)f + DEFAULT_RST - rst; \ fprintf(stderr, "(%d)\t", FORTHCELL(ip-1)); \ while(depth--) fprintf(stderr, "\t"); \ fprintf(stderr, "x %s (%d)\n", XT2LINK(current)->name->s_name, FORTHCELL(current)); \ } \ } // code field is 2 cells wide #define PFA(x) (((cell_t *)(x))+2) #define ADD_LINK(name) {add_link(f->active, name)->compile = xt_compile;} // add link with default compile semantics #define ADD_PRIMITIVE(name, label){ADD_LINK(gensym(name)); COMPILE(&&label);} /* post("%s : %x", name, &&label); */ #define COMPILE_PFA {cell_t *c = allot(f->active, sizeof(cell_t)); c[0] = (cell_t)(c+1);} // CHECK IF THIS IS CORRECT //#define JMP_CURRENT {DOTRACE(current); goto **current;} #define JMP_CURRENT {goto **current;} #define LATESTXT ((cell_t *)(&SENTINEL.prev[1])) /* local variables (cache & temp) */ forthsys_t *f = x->f; // moi int e = 0; // error code xt_t current = 0; // execution token of currently executing word // (points to code field 2 cells wide, followed by (data) parameter field) atom_t *atom = 0; // current input atom cell_t *dst = f->dst; // data stack pointer cell_t *rst = f->rst; // return stack pointer thread_t ip = f->ip; // next highlevel instruction (current thread) /* mark running */ running_forth = 1; #ifdef __unix__ /* install error handler TODO: check this properly: signals and pd do not seem to work very well. maybe it needs some restarting... */ if (sigsetjmp(longjmp_signal, 1)){ post("MOLE: got signal %d. resetting interpreter.", caught_signal); /* We can't trust any of the data structures so the best we can do is reset the interpreter execution. This does leave the program intact. Continuing afer a signal, esp. SIGSEGV is at your own risk of course. */ goto reset; } #endif /* if initialized, continue execution */ if (interpreter) NEXT; /* initialize */ PRIM("REBOOT", reboot){ post("MOLE: version " VERSION " booting"); broadcast_children(gensym("cleanup"), 0, 0); // call cleanup method /* switch to global mole/forth object */ x = &global_mole; f = x->f; init_forth(f, 0, gensym("FORTH:")); // reset f->active = f; /* create some words manually so we can cache their xt */ add_link(f, gensym("compile")); xt_compile = (xt_t)f->free; COMPILE(&&compile); XT2LINK(xt_compile)->compile = xt_compile; // bootstrapping is fun eiy ADD_LINK(gensym("execute")); xt_execute = (xt_t)f->free; COMPILE(&&execute); ADD_LINK(gensym("leave")); xt_leave = (xt_t)f->free; COMPILE(&&leave); ADD_LINK(gensym("lit")); xt_lit = (xt_t)f->free; COMPILE(&&lit); /* create the rest of the primitives (code generated by primitives.pl from this file) */ #include "primitives.h" /* mark immediate words */ SETIMMEDIATE("literal"); SETIMMEDIATE("["); SETIMMEDIATE("("); SETIMMEDIATE("ints"); SETIMMEDIATE("floats"); /* create top level interpreter loop (as raw threaded code) */ interpreter = (thread_t)f->free; WCOMPILE("accept"); WCOMPILE("interpret"); WCOMPILE("jmp"); COMPILE(interpreter); f->ip = interpreter; // next entry will start interpreter /* reload library */ mole_load(x, x->name); broadcast_children(gensym("init"), 0, 0); // re-initialize children broadcast_children(gensym("reload"), 0, 0); // reload all children /* exit directly discarding dirty local variables */ goto leaveforth_now; } /* INNER INTERPRETER */ next: current = *ip++; JMP_CURRENT; /* COMPILATION & EXECUTION */ PRIM("comma", comma) // same as compile compile: COMPILE(DS_POP); NEXT; execute: {current = (xt_t)(DS_POP); JMP_CURRENT;} leave: {ip = (thread_t)RS_POP; NEXT; } lit: {DS_PUSH = (cell_t)*ip++; NEXT;} PRIM("begin", loop){RS_PUSH = (cell_t)(ip - 1); NEXT;} PRIM("passto", passto){ // perform a tail call DS_PUSH = (cell_t)*ip; // get xt to jmp to ip = (thread_t)RS_POP; // leave goto execute; } PRIM("route-pass", route_pass){ // like pass, but using a table DS_TOP = (cell_t)ip[DS_TOP]; // get xt to jmp to ip = (thread_t)RS_POP; // leave goto execute; } PRIM("route", route){ // like route-pass, but do not execute leave ip += DS_POP; // get xt to jmp to NEXT; } /* NUMBER PARSING */ PRIM("numbers", numbers) {DS_PUSH = f->number; NEXT;} PRIM("ints", number_int) {f->number = NUMBER_INT; NEXT;} // integer number parsing mode PRIM("floats", number_float) {f->number = NUMBER_FLOAT; NEXT;} // floating point number parsing mode /* SIMPLE CODE FIELDS */ PRIM("enter", enter){RS_PUSH = (cell_t)ip; ip = (thread_t)(PFA(current)); NEXT;} PRIM("dovar", dovar){DS_PUSH = (cell_t)(PFA(current)); NEXT; } PRIM("doconst", doconst){DS_PUSH = (cell_t)(*PFA(current)); NEXT;} PRIM("dodefer", dodefer){DS_PUSH = (cell_t)(*PFA(current)); goto execute;} /* DOUBLE CODE FIELDS */ PRIM("dodoes", dodoes){RS_PUSH = (cell_t)ip; ip = (thread_t)current[1]; goto dovar;} /* OUTER INTERPRETER */ PRIM("accept", readatom){ACCEPT; NEXT;} // ( -- word type ) PRIM("interpret", interpret){ xt_t xt; atomtype_t type = (atomtype_t)DS_POP; /* handle types */ switch(type){ case A_FLOAT: if (f->number == NUMBER_INT) DS_TOP = (cell_t) (((float *)dst)[0]); if (f->state) goto literal; else {NEXT;} case A_SYMBOL: /* get xt */ xt = lookup(SENTINEL.prev, (symbol_t *)DS_TOP); if (!xt) goto error_notfound; DS_TOP = (cell_t)xt; // overwrite symbol address with codefield address if (f->state){ // if compile state : execute compile time semantics DS_PUSH = (cell_t) XT2LINK(xt)->compile; } goto execute; case A_NULL: /* end of input */ DS_POP; if (f->state){ // finish compilation (FIXME: this is a pd semicolon workaround) COMPILE(xt_leave); f->state = 0; } if (f->debug_flags & OUTER_TRACE) post(""); goto leaveforth; // end of input, return to caller default: post("illegal input atom type %d", type); goto quit; } } /* create highlevel word */ PRIM(":", colon){ ACCEPT; if (A_SYMBOL != ((atomtype_t)DS_POP)) {UNDO_DS_POP; goto error_type;} ADD_LINK((symbol_t *)DS_POP); // create new link COMPILE(&&enter); // compile first cf cell : enter code address COMPILE_PFA; // compile second cf cell anyway goto compile_mode; } PRIM("]", compile_mode){f->state = 1; NEXT;} PRIM("[", interpret_mode){f->state = 0;NEXT;} PRIM("literal", literal){COMPILE(xt_lit); goto compile;} PRIM("latestxt", latestxt){DS_PUSH = (cell_t)LATESTXT; NEXT;} PRIM("xt>ct", xttoct){link_t *l = XT2LINK((xt_t)DS_TOP); DS_PUSH = (cell_t)(l->compile); NEXT; } PRIM("ip!", setip){ip = (thread_t)(DS_POP); NEXT;} PRIM("ip@", getip){DS_PUSH = (cell_t)ip; NEXT;} PRIM(".d" , print_dec){post("%d", (int)DS_POP); NEXT;} PRIM(".x" , print_hex){post("0x%08x", (int)DS_POP); NEXT;} PRIM(".s" , print_symbol){symbol_t *s = (symbol_t *)(DS_POP); post("%s", s->s_name); NEXT;} PRIM(".f" , print_ft){float *f = (float *)dst++; post("%f", *f); NEXT;} /* these do not work well with tasks */ PRIM(".S", printdata){int i = (cell_t *)f + DEFAULT_DST - dst; fprintf(stderr, "<%d>", i); while (i-- > 0){ fprintf(stderr, " %d", dst[i]); } fprintf(stderr, "\n"); NEXT;} PRIM(".R", printreturn){int i = (cell_t *)f + DEFAULT_RST - rst; fprintf(stderr, "<%d>", i); while (i-- > 0){ fprintf(stderr, " 0x%08x", rst[i]); } fprintf(stderr, "\n"); NEXT;} #define IPRIM(name, label, op) PRIM(name, label){int i = (DS_POP); *dst op i; NEXT;} IPRIM("add", add, +=); IPRIM("sub", sub, -=); IPRIM("mul", mul, *=); IPRIM("div", div, /=); IPRIM("mod", mod, %=); IPRIM("and", and, &=); IPRIM("or", or, |=); IPRIM("xor", xor, ^=); IPRIM(">>", shiftright, >>=); IPRIM("<<", shiftleft, <<=); #define FPRIM(name, label, op) PRIM(name, label){float *f = (float *)dst++; f[1] op f[0]; NEXT;} FPRIM("fadd", fadd, +=); FPRIM("fsub", fsub, -=); FPRIM("fmul", fmul, *=); FPRIM("fdiv", fdiv, /=); PRIM("random", random_int) {DS_PUSH = random(); NEXT;} /* comments implemented as a word end of input in a comment is an error, obviously be careful about the fact that comma, simicolon and sometimes newline cause end of input. working around this seems to only make the errors more obscure */ PRIM("(", comment){ while (1){ atomtype_t type; symbol_t *s; ACCEPT; type = (atomtype_t)DS_POP; s = (symbol_t *)DS_POP; if (!type) goto error_input; if ((A_SYMBOL == type) && (gensym(")") == s)) NEXT; } } PRIM("allot", allot){allot(f->active, DS_POP); NEXT; } PRIM("free!", setfree){f->active->free = (cell_t *)DS_POP; NEXT; } PRIM("malloc", malloc){DS_TOP = (cell_t)malloc(DS_TOP); NEXT; } PRIM("mfree", mfree) { free((void *)DS_POP); NEXT; } PRIM("trim", trim){trim(f); NEXT; } PRIM("@", load){cell_t *c = (cell_t*)(DS_TOP); DS_TOP = c[0]; NEXT;} /* stack/array reading/writing */ PRIM("point.write", pointwrite) { cell_t **sp = (cell_t**)DS_POP; *(*sp)++ = DS_POP; NEXT; } PRIM("point.read", pointread) // same as stack.pop PRIM("stack.pop", stackpop) { cell_t **sp = (cell_t**)DS_TOP; DS_TOP = *(*sp)++; NEXT; } PRIM("stack.push", stackpush) { cell_t **sp = (cell_t**)DS_POP; *--(*sp) = DS_POP; NEXT; } /* counters */ PRIM("@postdec", loadpostdec){cell_t *c = (cell_t*)(DS_TOP); DS_TOP = (c[0])--; NEXT;} PRIM("@predec", loadpredec){cell_t *c = (cell_t*)(DS_TOP); DS_TOP = (--c[0]); NEXT;} PRIM("@postinc", loadpostinc){cell_t *c = (cell_t*)(DS_TOP); DS_TOP = (c[0])++; NEXT;} PRIM("@preinc", loadpreinc){cell_t *c = (cell_t*)(DS_TOP); DS_TOP = ++(c[0]); NEXT;} PRIM("!", store){ //post("storing to (%d)", DS_TOP); cell_t *c = (cell_t*)(DS_POP); c[0] = DS_POP; NEXT; } PRIM("lookup", plookup){ symbol_t *s = (symbol_t *)DS_TOP; xt_t xt = lookup(SENTINEL.prev, s); if (!xt) goto error_notfound; DS_TOP = (cell_t)xt; NEXT; } /* create a link using symbol on tos */ PRIM("link", link){symbol_t *s = (symbol_t *)(DS_POP); ADD_LINK(s); NEXT;} PRIM("rdrop", rdrop){RS_POP; NEXT;} PRIM(">r", tor){RS_PUSH = DS_POP; NEXT;} PRIM("r>", fromr){DS_PUSH = RS_POP; NEXT;} PRIM("r", rtop) {DS_PUSH = RS_TOP; NEXT;} PRIM("reset-rst", reset_rst) {rst = (cell_t *)f + DEFAULT_RST; NEXT;} PRIM("reset-dst", reset_dst) {dst = (cell_t *)f + DEFAULT_DST; NEXT;} PRIM("dsp@", get_dst) {dst[-1] = (cell_t)dst; dst--; NEXT;} PRIM("rsp@", get_rst) {DS_PUSH = (cell_t)rst; NEXT;} PRIM("dsp!", set_dst) {dst = (cell_t *)DS_TOP; NEXT;} PRIM("rsp!", set_rst) {rst = (cell_t*)DS_POP; NEXT;} PRIM("dup", dup) {cell_t a = DS_TOP; DS_PUSH = a; NEXT;} PRIM("over", over){cell_t a = DS_2ND; DS_PUSH = a; NEXT;} PRIM("drop", drop) {dst++; NEXT;} PRIM("swap", swap) {cell_t a = DS_TOP; DS_TOP = DS_2ND; DS_2ND = a; NEXT;} PRIM("words", words) {print_link(&SENTINEL); NEXT;} PRIM("save-words", savewords){save_link(&SENTINEL, ((symbol_t *)DS_POP)->s_name); NEXT;} PRIM("immediate", immediate){SENTINEL.prev->compile = xt_execute; NEXT;} PRIM("here", here){DS_PUSH = (cell_t)(f->active->free); NEXT; } #define JPRIM(name, label, cond) PRIM(name, label) {thread_t addr = (thread_t)(*ip++);if (cond) {ip = addr;} NEXT;} JPRIM("jmp", jmp, 1); JPRIM("jz", jz, (!(DS_POP))); JPRIM("jnz", jnz, (DS_POP)); JPRIM("decrjnz", decrjnz, (--(((int *)rst)[0]))); #define LPRIM(name, label, op) PRIM(name, label){cell_t b = DS_POP; cell_t a = DS_TOP; DS_TOP = a op b ? -1 : 0; NEXT;} LPRIM("lt", ilt, <); LPRIM("gt", igt, >); LPRIM("lte", ilte, <=); LPRIM("gte", igte, >=); LPRIM("eq", ieq, ==); #define FLPRIM(name, label, op) PRIM(name, label){float *f = (float *)(dst++); DS_TOP = f[1] op f[0] ? -1 : 0; NEXT;} FLPRIM("flt", flt, <); FLPRIM("fgt", fgt, >); FLPRIM("fgte", fgte, >=); FLPRIM("flte", flte, <=); FLPRIM("feq", feq, ==); #define SETFLAG(reg,flag,value){reg &= ~(flag); if(value) reg |= (flag);} PRIM("trace-inner!", setinnertrace){SETFLAG(f->debug_flags, INNER_TRACE, DS_POP); NEXT;} PRIM("trace-outer!", setoutertrace){SETFLAG(f->debug_flags, OUTER_TRACE, DS_POP); NEXT;} PRIM("f->i", floattoint){float *f = (float *)dst; DS_TOP = (int)(f[0]); NEXT;} PRIM("i->f", inttofloat){float *f = (float *)dst; f[0] = (float)(DS_TOP); NEXT;} #define DO_ASSERT(type){ \ atomtype_t t = (atomtype_t) DS_POP; \ if (type == t) { NEXT; } \ else if (!t) goto error_input; \ else {DS_PUSH = t; goto error_type;} \ } PRIM("assert-float", assert_float) DO_ASSERT(A_FLOAT) PRIM("assert-symbol", assert_symbol) DO_ASSERT(A_SYMBOL) PRIM("forth", dict_forth){f->active = global_mole.f; NEXT;} PRIM("local", dict_local){f->active = f; NEXT;} PRIM("rewind", rewind){ // ( link.ptr -- ) rewind dictionary link_t *l = (link_t*)DS_POP; SENTINEL.prev = l->prev; f->active->free = (cell_t *)l; NEXT; } /* queues */ PRIM("queue.read", readqueue){DS_TOP = queue_read((queue_t *)DS_TOP); NEXT;} PRIM("queue.write", writequeue){cell_t c = DS_POP; queue_write((queue_t *)c, DS_POP); NEXT;} PRIM("queue.tick", writereadqueue){queue_t *q = (queue_t *)DS_POP; queue_write(q, DS_TOP); DS_TOP = queue_read(q); NEXT;} PRIM("queue.elements", sizequeue){DS_TOP = queue_elements((queue_t *)DS_TOP); NEXT; } /* dsp port access. (port pointers are stored in cells 16->31 and are autoincrementing when used with following words) */ #define PORTFETCHPRIM(name, label, index) PRIM(name, label){DS_PUSH = *(((cell_t **)f)[DEFAULT_PORTS + index])++; NEXT;} PORTFETCHPRIM("p0>", p0fetch, 0); PORTFETCHPRIM("p1>", p1fetch, 1); PORTFETCHPRIM("p2>", p2fetch, 2); PORTFETCHPRIM("p3>", p3fetch, 3); PORTFETCHPRIM("p4>", p4fetch, 4); PORTFETCHPRIM("p5>", p5fetch, 5); #define PORTSTOREPRIM(name, label, index) PRIM(name, label){*(((cell_t **)f)[DEFAULT_PORTS + index])++ = DS_POP; NEXT;} PORTSTOREPRIM(">p0", p0store, 0); PORTSTOREPRIM(">p1", p1store, 1); PORTSTOREPRIM(">p2", p2store, 2); PORTSTOREPRIM(">p3", p3store, 3); PORTSTOREPRIM(">p4", p4store, 4); PORTSTOREPRIM(">p5", p5store, 5); /* forth regs */ PRIM("base", base){DS_PUSH = (cell_t)f; NEXT;} PRIM("blocksize", blocksize){DS_PUSH = f->n; NEXT;} PRIM("signal-inlets", sigin){DS_PUSH = f->signal_inlets; NEXT;} PRIM("signal-outlets", sigout){DS_PUSH = f->signal_outlets; NEXT;} /* pd */ // TODO: add pd object creation / destruction words // it would be nice to use pd's object system inside the forth.. PRIM("get-array", get_array){ // ( sym -- size ptr ) symbol_t *s = (symbol_t *)DS_TOP; garray_t *a = (garray_t *)pd_findbyclass(s, garray_class); dst--; // reserve a cell on DS if ((!a) || (!garray_getfloatarray(a, (int *)(dst+1), (float **)(dst)))){ DS_TOP = 0; // on error, load zeros DS_2ND = 0; NEXT; } garray_usedindsp(a); // don't know now, just to be sure.. NEXT; } PRIM("redraw-array", redraw_array){// ( sym -- ) garray_t *a = (garray_t *)pd_findbyclass((symbol_t *)DS_POP, garray_class); if (a){garray_redraw(a);} NEXT; } PRIM("bind", bind){ pd_bind(&x->obj.ob_pd, (symbol_t *)DS_POP); NEXT; } PRIM("unbind", unbind){ pd_unbind(&x->obj.ob_pd, (symbol_t *)DS_POP); NEXT; } PRIM("self", self) {DS_PUSH = (cell_t)x; NEXT; } PRIM("newest", newest) {DS_PUSH = (cell_t)pd_newest(); NEXT; } PRIM("factory", factory) {DS_PUSH = (cell_t)(&pd_objectmaker); NEXT; } PRIM("timer!", timer_delay){clock_delay(x->clock, ((float *)dst)[0]); DS_POP; NEXT;} PRIM("stop", timer_stop){clock_unset(x->clock); NEXT;} PRIM("vc[]", vcallv){ ((vc_0)(DS_POP))(); NEXT; } PRIM("vc[1]", vcall1){vc_1 f = (vc_1)(DS_POP); f(DS_POP); NEXT; } /* call a helper outside of this c-stack frame NOTE: the forth doesn't need the c stack. this is good. let's not intermingle with the c stack using recursive calls. it's possible to call pd methods (that will re-enter forth) from inside forth, i.e. mole objects sending messages to each other. there's nothing wrong with this, except that it introduces an unnecessary dependency on the c stack, which i rather avoid. i've opted to keep the c stack and forth completely separate, to keep some things clean and simple (and allowing nasty tricks to bypass pd's control flow). in order to achieve this independence, some functions need to be called as helpers running outside of this stack frame (which is only used as cache which needs to be flushed anyway if another re-entry can be made) this is also an alternative way to add extensions to mole itself, instead of adding them to the monolythic c kernel. */ #define DO_YIELD(routine) {e = YIELD_C; DS_PUSH = (cell_t)(routine); goto leaveforth; } PRIM("send", yield_send) DO_YIELD(c_mole_send); // send a pd message PRIM("load-module", yield_load) DO_YIELD(c_mole_load); // load a source file PRIM("new-inlet", yield_inlet) DO_YIELD(c_mole_new_inlet); PRIM("new-outlet", yield_outlet) DO_YIELD(c_mole_new_outlet); PRIM("pd-free", yield_pd_free) DO_YIELD(c_mole_pd_free); PRIM("pd-connect", yield_pd_connect) DO_YIELD(c_mole_pd_connect); PRIM("pd-disconnect", yield_pd_disconnect) DO_YIELD(c_mole_pd_disconnect); /* atom access */ PRIM("atoms", atoms){ DS_TOP *= sizeof(atom_t); NEXT; } PRIM("cells", cells){ DS_TOP <<= 2; NEXT; } PRIM("bytes", bytes){ DS_TOP >>= 2; NEXT; } PRIM("A_FLOAT", floattype) {DS_PUSH = A_FLOAT; NEXT; } PRIM("A_SYMBOL", symboltype) {DS_PUSH = A_SYMBOL; NEXT; } PRIM("A_POINTER", pointertype) {DS_PUSH = A_POINTER; NEXT; } /* error */ #define DO_ERROR(ee) {e = ee; goto reset;} PRIM("e-halt", error_halt) post("ERROR: unexpected end of thread"); DO_ERROR(ERROR_THREAD); PRIM("e-input", error_input) post("ERROR: unexpected end of input"); DO_ERROR(ERROR_INPUT); PRIM("e-type", error_type) post("ERROR: wrong type %d", (atomtype_t)DS_TOP); DO_ERROR(ERROR_TYPE); PRIM("e-undef", error_notfound) post("ERROR: undefined word %s", ((symbol_t *)DS_TOP)->s_name); DO_ERROR(ERROR_UNDEF); PRIM("e-signal", error_signal) post("ERROR: caught signal %d", DS_POP); DO_ERROR(ERROR_SIGNAL); PRIM("reset", reset){ // return to predictable state after error //post("MOLE: reset"); dst = (cell_t *)f + DEFAULT_DST; // clear data stack f->argc = 0; // reset input f->argv = 0; f->state = 0; // reset state f->active = f; // reset current dict to self goto quit; // reset data stack and return to interpreter // (which will leave forth since no more input) } // nonlocal exit from subroutine to interpreter (quit application) // data stack and input are left alone PRIM("quit", quit){ //post("MOLE: quit"); rst = (cell_t *)f + DEFAULT_RST; // clear return stack ip = interpreter; // return to interpreter NEXT; } leaveforth: if (!f->argc) f->argv = 0; f->dst = dst; f->rst = rst; f->ip = ip; leaveforth_now: running_forth = 0; return e; } #define S(a, x) ((a)[(x)].a_w.w_symbol) /* send a pd message */ void mole_send_pd_message(mole_t *x, atom_t *a){ pd_t *thing = 0; t_outlet *outlet = 0; int argc = 0; char *e = ""; t_atomtype target_type = 0, selector_type = 0; t_symbol *selector = 0; unsigned int port; //post("MOLE: sending from %d: class %d (%d)", // x, *((pd_t *)x), mole_class); while(a[argc].a_type != A_NULL){argc++;} // check syntax if (argc < 2) {e = "need target and selector/float"; goto error;} target_type = a[0].a_type; selector_type = a[1].a_type; // floats.. grmbl.. but it's convenient if ((argc == 2) && (selector_type == A_FLOAT)) { atom_t argv[4]; memcpy(argv, a, sizeof(atom_t)); // copy receiver SETSYMBOL(argv+1, gensym("float")); SETFLOAT(argv+2, a[1].a_w.w_float); memset(argv+3, 0, sizeof(atom_t)); // terminate with A_NULL mole_send_pd_message(x, argv); return; } // if not float, it needs to be a symbol if (selector_type != A_SYMBOL){ e = "invalid selector"; goto error; } selector = a[1].a_w.w_symbol; // get target if (target_type == A_SYMBOL){ if (!(thing = a[0].a_w.w_symbol->s_thing)) return; // vic not there } else if (target_type == A_POINTER){ thing = (pd_t *)a[0].a_w.w_index; } else { e = "invalid type"; goto error; } // patch argc and a argc -= 2; a += 2; if (!argc) a = 0; // send message to outlet or object port = (unsigned int)thing; if (port < MAX_NB_PORT){ // outlet if (port >= ((unsigned int)x->nb_outlets)) { e = "invalid output port"; goto error; } outlet = x->outlet[port]; outlet_anything(outlet, selector, argc, a); return; } else { // pd object //post("MOLE: sending to %d", thing); typedmess(thing, selector, argc, a); return; } return; error: post("ERROR: message error : %s", e); return; } /* forth<->c error and request handler a c helper coroutine or somtin */ static int run_forth(mole_t *x){ int e; while((e = enter_forth(x)) == YIELD_C) { ((mole_method_t)POP_DS(x->f))( x); } // exec helper return e; } /* PD MESSAGE HANDLING dumps everything to the input queue, and executes forth */ static void set_input(mole_t *x, int argc, atom_t *argv){ if (x->f->argc) post("ERROR: overriding previous input"); x->f->argc = argc; x->f->argv = argv; } #define SET_INPUT(f, c, v){f->argc = c; f->argv = 0;} static void mole_float(mole_t *x, float f){ atom_t a; SETFLOAT(&a, f); set_input(x, 1, &a); run_forth(x); } static void mole_anything(mole_t *x, symbol_t *s, int argc, atom_t *argv){ /* list? -> just pass */ if (s == &s_list) { set_input(x, argc, argv); run_forth(x); } /* other? pass selector too */ else { atom_t new_argv[argc+1]; memcpy(new_argv + 1, argv, sizeof(atom_t) * argc); SETSYMBOL(new_argv, s); set_input(x, argc+1, new_argv); run_forth(x); } } static atom_t dsp_command; static atom_t tick_command; static int *mole_perform(int *w) { int *dummy = w++; // skip perform() address mole_t *x = (mole_t *)(*w++); // get self int nbvec = x->f->signal_inlets + x->f->signal_outlets; cell_t **vec = (cell_t **)(x->f) + DEFAULT_PORTS; // write to port registers while (nbvec--) *vec++ = (cell_t *)(*w++); // copy vectors to forth // execute set_input(x, 1, &dsp_command); run_forth(x); return w; } static void mole_dsp(mole_t *x, signal_t **sp) { int nbvec = x->f->signal_inlets + x->f->signal_outlets; int vec[nbvec+1]; // argument vector int *pvec = vec, i; *pvec++ = (int)x; // copy self pointer x->f->n = (int)sp[0]->s_n; // store buffer size while (nbvec--) *pvec++ = (int)((*sp++)->s_vec); // copy signal vectors dsp_addv(mole_perform, pvec-vec, vec); } static void mole_tick(mole_t *x) { set_input(x, 1, &tick_command); run_forth(x); } /* PD SETUP */ /* load a file and execute it */ static int mole_load(mole_t *x, symbol_t *s) { char filename[strlen(s->s_name) + strlen(".mole") + 1]; void *binbuf; int e, argc, prev_argc; atom_t *argv, *prev_argv; atom_t reset; strcpy(filename, s->s_name); strcat(filename, ".mole"); post("MOLE: loading %s", filename); binbuf = binbuf_new(); /* why does canvas_getcurrent return 0 when called outside a constructor ? to work around this we store the current dir as a symbol and replace it each time we CAN access the canvas */ if (binbuf_read_via_path(binbuf, filename, canvas_getdir(x->canvas)->s_name, 0)){ post("ERROR: can't open %s", filename); return -13; } e = 0; argc = binbuf_getnatom(binbuf); argv = binbuf_getvec(binbuf); /* save input context */ prev_argv = x->f->argv; prev_argc = x->f->argc; /* enter interpreter */ *--(x->f->rst) = (cell_t)x->f->ip; x->f->ip = interpreter; x->f->argv = argv; x->f->argc = 0; while (argc) { switch(argv->a_type){ case A_COMMA: // will be mapped to 'comma' (note you can only use this in binbufs (source files)) argv->a_type = A_SYMBOL; argv->a_w.w_symbol = gensym("comma"); //post("WARNING: comma detected in input file"); case A_SEMI: if (x->f->argc) { if ((e = run_forth(x))) goto error; // execute a line } x->f->argv = argv+1; // reset input to next element x->f->argc = 0; break; default: (x->f->argc)++; break; } argv++; argc--; } // run remaining code if (x->f->argc) if ((e = run_forth(x))) goto error; done: /* leave interpreter */ x->f->ip = (thread_t)(*(x->f->rst)++); /* restore input context */ x->f->argv = prev_argv; x->f->argc = prev_argc; /* free binbuf */ binbuf_free(binbuf); return e; error: /* reset machine */ post("ERROR: error %d loading %s", e, filename); /* free binbuf */ binbuf_free(binbuf); /* reset forth */ SETSYMBOL(&reset, gensym("reset")); x->f->argv = &reset; x->f->argc = 1; run_forth(x); return e; } static void mole_init(mole_t *x){ init_forth(x->f, global_mole.f, gensym("OBJECT:")); x->f->signal_inlets = 1; x->f->signal_outlets = 0; x->nb_inlets = 1; x->nb_outlets = 0; } static void mole_free(mole_t *x){ mole_anything(x, gensym("cleanup"), 0, 0); free (x->f); unregister_mole(x); // unregister clock_free(x->clock); free(x->f); } // need to call clear before calling this static void mole_reload(mole_t *x){ mole_load(x, x->name); } static void mole_reset(mole_t *x){ post("MOLE: resetting [mole %s] (%d)", x->name->s_name, x); mole_anything(x, gensym("cleanup"), 0, 0); mole_init(x); mole_reload(x); } static int boot_forth(void); static void *mole_new(symbol_t *mole, int argc, atom_t *argv){ symbol_t *s; mole_t *x; int forth_cells = 0x1000; if (!initialized) { boot_forth(); // workaround to make mole loadable as -lib } if (argc < 1){s = gensym("console");} // no module -> console else { if (argv[0].a_type != A_SYMBOL){return 0;} s = argv[0].a_w.w_symbol; argc--; argv++; } x = (mole_t *)pd_new(mole_class); x->canvas = canvas_getcurrent(); x->name = s; x->clock = clock_new(x, (t_method)mole_tick); memset(x->outlet, 0, sizeof(outlet_t*) * MAX_NB_PORT); memset(x->inlet, 0, sizeof(inlet_t*) * MAX_NB_PORT); x->nb_outlets = 0; x->nb_inlets = 1; x->f = malloc(sizeof(cell_t) * forth_cells); // allocate forth = linear mem buffer x->f->forth_cells = forth_cells; /* this static allocation is a pain in the ass how much memory should we reserve? problem is: addresses are absolute, so we can't just start moving the code around... this is a real problem. */ mole_init(x); // initialize it x->f->signal_inlets = 1; x->f->signal_outlets = 0; mole_load(x, s); register_mole(x); // register set_input(x, argc, argv); // connect command line run_forth(x); // execute it //post("MOLE: new object %s (%d)", x->name->s_name, x); //post("MOLE: class %d (%d)", mole_class, *((pd_t *)x)); return x; } /* boot the main forth */ static int boot_forth(void){ int e = 0; canvas_t *canvas = canvas_getcurrent(); if (!canvas){ post("ERROR: canvas_getcurrent() failed."); return -1; } global_forth = malloc(sizeof(cell_t) * FORTH_CELLS); global_mole.f = (forthsys_t *)global_forth; global_mole.f->forth_cells = FORTH_CELLS; global_mole.name = gensym("kernel"); global_mole.canvas = canvas; interpreter = 0; init_forth(global_mole.f, 0, gensym("FORTH:")); if (e = run_forth(&global_mole)) return e; // compile primitives + load library code /* done */ initialized = 1; return e; } /* initialize pd stuff */ void mole_setup(void){ int e = 0; #ifdef __unix__ setup_unix(); // install signal handler #endif SETSYMBOL(&dsp_command, gensym("perform")); // some symbol caches SETSYMBOL(&tick_command, gensym("tick")); mole_class = class_new(gensym("mole"), (newmethod_t)mole_new, (method_t)mole_free, sizeof(mole_t), 0, A_GIMME, 0); CLASS_MAINSIGNALIN(mole_class, mole_t, dc); class_addanything(mole_class, (method_t)mole_anything); class_addfloat(mole_class, (method_t)mole_float); class_addmethod(mole_class, (t_method)mole_dsp, gensym("dsp"), A_NULL); class_addmethod(mole_class, (t_method)mole_reset, gensym("RESET"), A_NULL); class_addmethod(mole_class, (t_method)mole_init, gensym("init"), A_NULL); class_addmethod(mole_class, (t_method)mole_reload, gensym("reload"), A_NULL); return; }