diff options
Diffstat (limited to 'toxy/plustot.c')
| -rw-r--r-- | toxy/plustot.c | 2020 |
1 files changed, 2020 insertions, 0 deletions
diff --git a/toxy/plustot.c b/toxy/plustot.c new file mode 100644 index 0000000..bfaeb32 --- /dev/null +++ b/toxy/plustot.c @@ -0,0 +1,2020 @@ +/* Copyright (c) 2003 krzYszcz and others. + * For information on usage and redistribution, and for a DISCLAIMER OF ALL + * WARRANTIES, see the file, "LICENSE.txt," in this distribution. */ + +#include <string.h> +#include "m_pd.h" +#include "g_canvas.h" +#include "common/loud.h" +#include "common/grow.h" +#include "hammer/file.h" +#include "common/props.h" +#include "toxy/scriptlet.h" +#include "toxy/plusbob.h" +#include "plustot.h" +#include "build_counter" + +#define PLUSTOT_VERBOSE +#define PLUSTOT_DEBUG +//#define PLUSTOT_DEBUGREFCOUNTS + +#ifdef PLUSTOT_DEBUG +# define PLUSDEBUG_ENDPOST(fn) endpost() +#else +# define PLUSDEBUG_ENDPOST(fn) +#endif + +#ifdef PLUSTOT_DEBUGREFCOUNTS +# define PLUSDEBUG_INCRREFCOUNT(ob, fn) \ + {post("++ %x "fn, (int)(ob)); Tcl_IncrRefCount(ob);} +# define PLUSDEBUG_DECRREFCOUNT(ob, fn) \ + {post("-- %x "fn, (int)(ob)); Tcl_DecrRefCount(ob);} +#else +# define PLUSDEBUG_INCRREFCOUNT(ob, fn) Tcl_IncrRefCount(ob) +# define PLUSDEBUG_DECRREFCOUNT(ob, fn) Tcl_DecrRefCount(ob) +#endif + +static t_symbol *plusps_tot; +static t_symbol *plusps_env; +static t_symbol *plusps_in; +static t_symbol *plusps_var; +static t_symbol *plusps_out; +static t_symbol *plusps_qlist; +static t_symbol *plusps_print; +static t_symbol *totps_query; + +static void plusloud_tcldirty(t_pd *caller, char *fnname) +{ + loud_warning((caller == PLUSBOB_OWNER ? 0 : caller), + "(%s) tcl plays dirty tricks, sorry", fnname); +} + +void plusloud_tclerror(t_pd *caller, Tcl_Interp *interp, char *msg) +{ + Tcl_Obj *ob = Tcl_GetObjResult(interp); + loud_error((caller == PLUSBOB_OWNER ? 0 : caller), msg); + if (ob) + { + int len; + char *res = Tcl_GetStringFromObj(ob, &len); + if (res && len > 0) + { + char buf[MAXPDSTRING]; + if (len > (MAXPDSTRING-2)) + { + len = (MAXPDSTRING-2); + buf[MAXPDSTRING-2] = '*'; + buf[MAXPDSTRING-1] = 0; + } + else buf[len] = 0; + strncpy(buf, res, len); + loud_errand((caller == PLUSBOB_OWNER ? 0 : caller), + "(tcl) %s", buf); + } + else ob = 0; + Tcl_ResetResult(interp); + } + if (!ob) loud_errand((caller == PLUSBOB_OWNER ? 0 : caller), + "unknown error (probably a bug)"); +} + +/* Plustin (aka +Ti) is a Tcl_Interp wrapped as a +bob. + This is a glist-based flavor of Plusenv. */ + +struct _plustin +{ + t_plusenv tin_env; + t_glist *tin_glist; + Tcl_Interp *tin_interp; +}; + +static t_plustype *plustin_basetype; +static t_plustype *plustin_type; +static t_plustin *plustin_default = 0; + +/* To be called from derived constructors or plustin's provider. */ +t_plustin *plustin_create(t_plustype *tp, t_plusbob *parent, t_symbol *id) +{ + t_plustin *tin = 0; + Tcl_Interp *interp = Tcl_CreateInterp(); + if (interp && (tin = (t_plustin *)plusenv_create(tp, parent, id))) + { +#ifdef PLUSTOT_DEBUG + post("plustin_create '%s' over %x", + (id ? id->s_name : "default"), (int)interp); +#endif + tin->tin_interp = interp; + Tcl_Preserve(interp); + if (Tcl_Init(interp) == TCL_ERROR) + plusloud_tclerror(0, interp, "interpreter initialization failed"); + Tcl_Release(interp); + } + else loud_error(0, "failed attempt to create an interpreter"); + return (tin); +} + +/* To be registered for calling from plusbob_release(). + Should never be called explicitly. */ +static void plustin_delete(t_plustin *tin) +{ +#ifdef PLUSTOT_DEBUG + t_symbol *id = plusenv_getid((t_plusenv *)tin); + post("plustin_delete '%s' over %x", + (id ? id->s_name : "default"), (int)tin->tin_interp); +#endif + Tcl_Preserve(tin->tin_interp); + if (!Tcl_InterpDeleted(tin->tin_interp)) + Tcl_DeleteInterp(tin->tin_interp); + Tcl_Release(tin->tin_interp); +} + +Tcl_Interp *plustin_getinterp(t_plustin *tin) +{ + return (tin->tin_interp); +} + +t_symbol *plustin_glistid(t_glist *gl) +{ + char buf[32]; + sprintf(buf, "+ti%x", (int)gl); + return (gensym(buf)); +} + +t_plustin *plustin_glistfind(t_glist *gl, int mode) +{ + t_plustin *tin = 0; + if (mode == PLUSTIN_GLIST_UP) + { + gl = gl->gl_owner; + mode = PLUSTIN_GLIST_ANY; + } + if (mode == PLUSTIN_GLIST_THIS) + return ((t_plustin *)plusenv_find(plustin_glistid(gl), + (t_plusenv *)plustin_default)); + else + { + while (gl) + { + char buf[32]; + sprintf(buf, "+ti%x", (int)gl); + if (tin = (t_plustin *)plusenv_find(gensym(buf), + (t_plusenv *)plustin_default)) + break; + gl = gl->gl_owner; + } + return (tin ? tin : plustin_default); + } +} + +/* To be called from client code, instead of plustin_create(). + Preserving is caller's responsibility. + Never returns null, even when called with create == 0: + if requested id not found, default returned, created if necessary. */ +t_plustin *plustin_glistprovide(t_glist *gl, int mode, int create) +{ + t_plustin *tin = 0; + t_plusbob *parent = plusenv_getparent(plustin_type); + if (mode == PLUSTIN_GLIST_UP) + { + gl = gl->gl_owner; + mode = PLUSTIN_GLIST_ANY; + } + tin = plustin_glistfind(gl, mode); + if (!tin && create) + { + if (tin = plustin_create(plustin_type, parent, plustin_glistid(gl))) + tin->tin_glist = gl; + } + if (!tin) + { + if (!plustin_default) + plustin_default = plustin_create(plustin_type, parent, 0); + tin = plustin_default; + } + return (tin); +} + +t_symbol *plustin_getglistname(t_plustin *tin) +{ + return (tin->tin_glist ? tin->tin_glist->gl_name : 0); +} + +/* Plustob (aka +To) is a Tcl_Obj wrapped as a +bob. */ + +/* LATER rethink the plustob/plusvar rules, measure performance. + There are two cases: + + `Bobbing' is taking an object from its wrapping bob, wrapping it into + another bob and, optionally, setting a variable to it. + + The main deal of bobbing design is not to Tcl_DuplicateObj while passing + bobs around. + + `Messing' is converting a Pd message (float, symbol or list) to an object, + wrapping it and, optionally, setting a variable to it. + + The obvious sequence of {Decr(old), New, Incr(new), SetVar(new)}, which + is currently used, involves picking a new object (New), while returning + an old one to the pool (by SetVar or Decr, depending on a third party + changing or not the tcl variable's value in the meantime). I guess + the overhead is negligible, unless we hit at the bottom of the pool. + Moreover, we can reduce the sequence to just {Set(old), SetVar(old)}, + in the case when old is not shared (referenced neither by a variable, + nor by a third party). The main advantage is being consistent with + the way Tcl itself was designed. + + An alternative: in the original messing design, the trick was to: + + . call Set on a prepicked object, instead of New + . call SetVar on a preserved object, as usual (var would not own its value) + . alternate between two prepicked objects in order to avoid calling UnsetVar + + So, the sequence was just {Set(v1), SetVar(v1)}, then {Set(v2), SetVar(v2)}, + again {Set(v1), SetVar(v1)}, and so on, unless a third party (other than + plusvar and a tcl variable) referenced our prepicked object. */ + +#define PLUSTOB_INIELBUFSIZE 128 /* LATER rethink */ + +struct _plustob +{ + t_plusbob tob_bob; + Tcl_Obj *tob_value; + t_plustin *tob_tin; /* redundant, LATER rethink */ + t_plusifsharedfn tob_ifsharedfn; + int tob_elbufsize; + Tcl_Obj **tob_elbuf; + Tcl_Obj *tob_elbufini[PLUSTOB_INIELBUFSIZE]; +}; + +static t_plustype *plustob_type; + +/* To be called from derived constructors. + Preserving is caller's responsibility. */ +t_plustob *plustob_create(t_plustype *tp, t_plustin *tin, Tcl_Obj *ob) +{ + t_plustob *tob = 0; + if (tin && (ob != PLUSTOB_MAKEIT || (ob = Tcl_NewObj())) + && (tob = (t_plustob *)plusbob_create(tp, (t_plusbob *)tin))) + { + if (ob) PLUSDEBUG_INCRREFCOUNT(ob, "plustob_create"); + plusbob_preserve((t_plusbob *)tin); + tob->tob_value = ob; + tob->tob_tin = tin; + tob->tob_ifsharedfn = 0; + tob->tob_elbufsize = PLUSTOB_INIELBUFSIZE; + tob->tob_elbuf = tob->tob_elbufini; + } + return (tob); +} + +/* To be registered for calling from plusbob_release(). + Should never be called explicitly. */ +static void plustob_delete(t_plustob *tob) +{ + if (tob->tob_tin) + plusbob_release((t_plusbob *)tob->tob_tin); + if (tob->tob_value) + PLUSDEBUG_DECRREFCOUNT(tob->tob_value, "plustob_delete"); + if (tob->tob_elbuf != tob->tob_elbufini) + freebytes(tob->tob_elbuf, tob->tob_elbufsize * sizeof(*tob->tob_elbuf)); +} + +/* To be registered for calling from plusbob_attach(). + Should never be called explicitly. */ +static void plustob_attach(t_plustob *tob) +{ + t_plustin *tin; + if (tin = (t_plustin *)plusbob_getparent((t_plusbob *)tob)) + { + if (tob->tob_tin) + plusbob_release((t_plusbob *)tob->tob_tin); + tob->tob_tin = tin; + plusbob_preserve((t_plusbob *)tin); + } + else bug("plustob_attach"); +} + +/* To be called from client code. + Preserving is caller's responsibility. */ +t_plustob *plustob_new(t_plustin *tin, Tcl_Obj *ob) +{ + return (plustob_create(plustob_type, tin, ob)); +} + +void plustob_setifshared(t_plustob *tob, t_plusifsharedfn ifsharedfn) +{ + tob->tob_ifsharedfn = ifsharedfn; +} + +int plustob_isshared(t_plustob *tob) +{ + return (tob->tob_value && Tcl_IsShared(tob->tob_value)); +} + +Tcl_Obj *plustob_getvalue(t_plustob *tob) +{ + return (tob->tob_value); +} + +/* silent, if caller is empty */ +t_plustin *plustag_tobtin(t_symbol *tag, t_pd *caller) +{ + return (plustag_validroot(tag, plusps_To, caller) + ? ((t_plustob *)tag)->tob_tin : 0); +} + +/* silent, if caller is empty */ +Tcl_Obj *plustag_tobvalue(t_symbol *tag, t_pd *caller) +{ + return (plustag_validroot(tag, plusps_To, caller) + ? ((t_plustob *)tag)->tob_value : 0); +} + +/* silent, if caller is empty */ +Tcl_Obj *plusatom_tobvalue(t_atom *ap, t_pd *caller) +{ + if (ap->a_type == A_SYMBOL) + return (plustag_tobvalue(ap->a_w.w_symbol, caller)); + else if (caller) + { + char buf[80]; + atom_string(ap, buf, 80); + loud_error((caller == PLUSBOB_OWNER ? 0 : caller), + "+tot does not understand '%s' (check object connections)", buf); + } + return (0); +} + +Tcl_Obj *plustob_set(t_plustob *tob, t_plustin *tin, Tcl_Obj *ob) +{ + if (tin != tob->tob_tin) + { + /* FIXME */ + loud_warning(0, "+To: environment mismatch"); + return (0); + } + if (ob != tob->tob_value) + { + if (tob->tob_value) + PLUSDEBUG_DECRREFCOUNT(tob->tob_value, "plustob_set"); + if (ob) + { + PLUSDEBUG_INCRREFCOUNT(ob, "plustob_set"); + if (Tcl_IsShared(ob)) + { + /* FIXME */ + } + } + tob->tob_value = ob; + } + return (ob); +} + +Tcl_Obj *plustob_setfloat(t_plustob *tob, t_float f) +{ + Tcl_Obj *ob = tob->tob_value; + if (!ob || Tcl_IsShared(ob)) + { + Tcl_Obj *tmp; + int i = (int)f; + if (ob && tob->tob_ifsharedfn) + { + if ((*tob->tob_ifsharedfn)((t_plusbob *)tob, ob) == 0) + return (0); + } + if (f == i) /* LATER rethink */ + tmp = Tcl_NewIntObj(i); + else + tmp = Tcl_NewDoubleObj((double)f); + if (tmp) + { + if (ob) PLUSDEBUG_DECRREFCOUNT(ob, "plustob_setfloat"); + tob->tob_value = ob = tmp; + PLUSDEBUG_INCRREFCOUNT(ob, "plustob_setfloat"); + } + else return (0); + } + else + { + int i = (int)f; + if (f == i) /* LATER rethink */ + Tcl_SetIntObj(ob, i); + else + Tcl_SetDoubleObj(ob, (double)f); + } + return (ob); +} + +Tcl_Obj *plustob_setsymbol(t_plustob *tob, t_symbol *s) +{ + if (plustag_isvalid(s, 0)) + { + if (plustag_validroot(s, plusps_To, PLUSBOB_OWNER)) + { + t_plustob *from = (t_plustob *)s; + return (plustob_set(tob, from->tob_tin, from->tob_value)); + } + else return (0); + } + else + { + Tcl_Obj *ob = tob->tob_value; + if (!ob || Tcl_IsShared(ob)) + { + Tcl_Obj *tmp; + if (ob && tob->tob_ifsharedfn) + { + if ((*tob->tob_ifsharedfn)((t_plusbob *)tob, ob) == 0) + return (0); + } + if (tmp = Tcl_NewStringObj(s->s_name, -1)) + { + if (ob) PLUSDEBUG_DECRREFCOUNT(ob, "plustob_setsymbol"); + tob->tob_value = ob = tmp; + PLUSDEBUG_INCRREFCOUNT(ob, "plustob_setsymbol"); + } + else return (0); + } + else Tcl_SetStringObj(ob, s->s_name, -1); + return (ob); + } +} + +Tcl_Obj *plustob_setlist(t_plustob *tob, int ac, t_atom *av) +{ + if (ac == 1) + { + if (av->a_type == A_FLOAT) + return (plustob_setfloat(tob, av->a_w.w_float)); + else if (av->a_type == A_SYMBOL) + return (plustob_setsymbol(tob, av->a_w.w_symbol)); + } + else if (ac > 1) + { + Tcl_Obj *ob = tob->tob_value; + int count; + t_atom *ap; + for (count = 0, ap = av; count < ac; count++, ap++) + if (ap->a_type != A_FLOAT && ap->a_type != A_SYMBOL) + break; + if (count > tob->tob_elbufsize) + { +#ifdef PLUSTOT_DEBUG + post("growing +To %d -> %d", tob->tob_elbufsize, count); +#endif + tob->tob_elbuf = + grow_nodata(&count, &tob->tob_elbufsize, tob->tob_elbuf, + PLUSTOB_INIELBUFSIZE, tob->tob_elbufini, + sizeof(*tob->tob_elbuf)); + } + if (count > 0) + { + int i; + Tcl_Obj **elp; + for (i = 0, elp = tob->tob_elbuf; i < count; i++, elp++, av++) + { + if (av->a_type == A_FLOAT) + *elp = Tcl_NewDoubleObj((double)av->a_w.w_float); + else if (av->a_type == A_SYMBOL) + *elp = Tcl_NewStringObj(av->a_w.w_symbol->s_name, -1); + } + if (!ob || Tcl_IsShared(ob)) + { + Tcl_Obj *tmp; + if (ob && tob->tob_ifsharedfn) + { + if ((*tob->tob_ifsharedfn)((t_plusbob *)tob, ob) == 0) + return (0); + } + if (tmp = Tcl_NewListObj(count, tob->tob_elbuf)) + { + if (ob) PLUSDEBUG_DECRREFCOUNT(ob, "plustob_setlist"); + tob->tob_value = ob = tmp; + PLUSDEBUG_INCRREFCOUNT(ob, "plustob_setlist"); + } + else return (0); + } + else Tcl_SetListObj(ob, count, tob->tob_elbuf); + return (ob); + } + } + return (0); /* count == 0, LATER rethink */ +} + +static int plustob_parseatoms(int ac, t_atom *av, int *natomsp, int *nlistsp, + Tcl_Obj **listobs, Tcl_Obj **atomobs) +{ + int i, natoms = 0, nlists = 0, start = 1; + t_atom *ap; + int atomcnt = 0; + Tcl_Obj **atomptr = atomobs; + for (i = 0, ap = av; i < ac; i++, ap++) + { + if (ap->a_type == A_SEMI || ap->a_type == A_COMMA) + { + /* empty lists are filtered out, LATER rethink */ + if (!start) + { + if (listobs) + { + if (listobs[nlists] = Tcl_NewListObj(atomcnt, atomptr)) + { + atomptr += atomcnt; + atomcnt = 0; + } + else goto parsefailed; + } + nlists++; + } + start = 1; + } + else + { + /* other types are ignored, LATER rethink */ + start = 0; + if (ap->a_type == A_FLOAT || ap->a_type == A_SYMBOL) + { + if (atomobs) + { + if (!(atomobs[natoms] = + (ap->a_type == A_FLOAT ? + Tcl_NewDoubleObj((double)ap->a_w.w_float) : + Tcl_NewStringObj(ap->a_w.w_symbol->s_name, -1)))) + goto parsefailed; + atomcnt++; + } + natoms++; + } + } + } + if (natoms && !start) + { + if (listobs && + !(listobs[nlists] = Tcl_NewListObj(atomcnt, atomptr))) + goto parsefailed; + nlists++; + } + if (natomsp) *natomsp = natoms; + if (nlistsp) *nlistsp = nlists; + return (1); +parsefailed: + /* FIXME cleanup */ + return (0); +} + +Tcl_Obj *plustob_setbinbuf(t_plustob *tob, t_binbuf *bb) +{ + int ac = binbuf_getnatom(bb); + if (ac) + { + t_atom *av = binbuf_getvec(bb); + Tcl_Obj *ob = tob->tob_value; + int count, natoms, nlists; + plustob_parseatoms(ac, av, &natoms, &nlists, 0, 0); + count = natoms + nlists; + if (count > tob->tob_elbufsize) + { + int n = count; +#ifdef PLUSTOT_DEBUG + post("growing +To %d -> %d", tob->tob_elbufsize, count); +#endif + tob->tob_elbuf = + grow_nodata(&n, &tob->tob_elbufsize, tob->tob_elbuf, + PLUSTOB_INIELBUFSIZE, tob->tob_elbufini, + sizeof(*tob->tob_elbuf)); + if (n < count) + goto setbbfailed; + } + if (!plustob_parseatoms(ac, av, 0, 0, + tob->tob_elbuf, tob->tob_elbuf + nlists)) + goto setbbfailed; + if (!ob || Tcl_IsShared(ob)) + { + Tcl_Obj *tmp; + if (ob && tob->tob_ifsharedfn) + { + if ((*tob->tob_ifsharedfn)((t_plusbob *)tob, ob) == 0) + goto setbbfailed; + } + if (tmp = Tcl_NewListObj(nlists, tob->tob_elbuf)) + { + if (ob) PLUSDEBUG_DECRREFCOUNT(ob, "plustob_setbinbuf"); + tob->tob_value = ob = tmp; + PLUSDEBUG_INCRREFCOUNT(ob, "plustob_setbinbuf"); + } + else goto setbbfailed; + } + else Tcl_SetListObj(ob, nlists, tob->tob_elbuf); + return (ob); + } +setbbfailed: + return (0); +} + +Tcl_Obj *plustob_grabresult(t_plustob *tob) +{ + Tcl_Interp *interp = tob->tob_tin->tin_interp; + Tcl_Obj *rob; + if (rob = Tcl_GetObjResult(interp)) + { + if (rob == tob->tob_value) + Tcl_ResetResult(interp); + else + { + PLUSDEBUG_INCRREFCOUNT(rob, "plustob_grabresult"); + Tcl_ResetResult(interp); + if (Tcl_IsShared(rob)) + { + /* FIXME */ + } + if (tob->tob_value) + PLUSDEBUG_DECRREFCOUNT(tob->tob_value, "plustob_grabresult"); + tob->tob_value = rob; + } + } + else plusloud_tcldirty(plusbob_getowner((t_plusbob *)tob), + "plustob_grabresult"); + return (rob); +} + +Tcl_Obj *plustob_evalob(t_plustob *tob, Tcl_Obj *ob) +{ + Tcl_Interp *interp = tob->tob_tin->tin_interp; + Tcl_Obj *rob; + Tcl_Preserve(interp); + if (Tcl_EvalObj(interp, ob) == TCL_OK) + rob = plustob_grabresult(tob); + else + { + plusloud_tclerror(plusbob_getowner((t_plusbob *)tob), interp, + "immediate command failed"); + rob = 0; + } + Tcl_Release(interp); + return (rob); +} + +/* Plusvar (aka +Tv) is a plustob with a one-way link to a tcl variable. + Whenever plusvar's value changes, the variable is set to it (the opposite + update requires explicitly calling the plusvar_pull() request). + This is different from one-way linking by passing TCL_LINK_READ_ONLY flag + to Tcl_LinkVar(): plusvar's variable is not forced to be read-only, + and its value's form and internal representation are not constrained. */ + +struct _plusvar +{ + t_plustob var_tob; + char *var_name; + char *var_index; + Tcl_Obj *var_part1; + Tcl_Obj *var_part2; +}; + +static t_plustype *plusvar_type; + +/* Since tcl always uses a hash table of string indices for array element + lookup, there are never any gains when using integer indices. */ + +/* To be called from derived constructors. + Preserving is caller's responsibility. */ +t_plusvar *plusvar_create(t_plustype *tp, t_plustin *tin, Tcl_Obj *ob, + char *name, char *index) +{ + t_plusvar *var = 0; + Tcl_Obj *ntob = 0; + Tcl_Obj *itob = 0; + if (name && *name) + { + if (ntob = Tcl_NewStringObj(name, -1)) + { + PLUSDEBUG_INCRREFCOUNT(ntob, "plusvar_create"); + } + else goto varfailed1; + } + else + { + bug("plusvar_create"); + goto varfailed2; + } + if (index) + { + if (itob = Tcl_NewStringObj(index, -1)) + { + PLUSDEBUG_INCRREFCOUNT(itob, "plusvar_create"); + } + else goto varfailed1; + } + if (var = (t_plusvar *)plustob_create(tp, tin, ob)) + { + var->var_name = getbytes(strlen(name) + 1); + strcpy(var->var_name, name); + if (index) + { + var->var_index = getbytes(strlen(index) + 1); + strcpy(var->var_index, index); + } + else var->var_index = 0; + var->var_part1 = ntob; + var->var_part2 = itob; + } + else goto varfailed2; + return (var); +varfailed1: + plusloud_tcldirty(0, "plusvar_create"); +varfailed2: + if (ntob) PLUSDEBUG_DECRREFCOUNT(ntob, "plusvar_create"); + if (itob) PLUSDEBUG_DECRREFCOUNT(itob, "plusvar_create"); + return (0); +} + +/* To be registered for calling from plusbob_release(). + Should never be called explicitly. */ +static void plusvar_delete(t_plusvar *var) +{ + freebytes(var->var_name, strlen(var->var_name) + 1); + if (var->var_index) + freebytes(var->var_index, strlen(var->var_index) + 1); + PLUSDEBUG_DECRREFCOUNT(var->var_part1, "plusvar_delete"); + if (var->var_part2) + PLUSDEBUG_DECRREFCOUNT(var->var_part2, "plusvar_delete"); +} + +/* To be called from client code. + Preserving is caller's responsibility */ +t_plusvar *plusvar_new(char *name, char *index, t_plustin *tin) +{ + return (plusvar_create(plusvar_type, tin, 0, name, index)); +} + +/* not used yet */ +static int plusvar_ifshared(t_plusbob *bob, Tcl_Obj *ob) +{ + /* Shared means either the variable still holds our value, or the value + is referenced by a third party, or both. In either case, we have to + pick a new object. + LATER consider testing for illegal use of a pseudo-variable. */ + return (1); +} + +/* LATER try making it more efficient */ +static Tcl_Obj *plusvar_postset(t_plusvar *var) +{ + Tcl_Obj *rob; + t_plustob *tob = (t_plustob *)var; + Tcl_Interp *interp = tob->tob_tin->tin_interp; + Tcl_Preserve(interp); + if (tob->tob_value) + { + rob = Tcl_ObjSetVar2(interp, var->var_part1, var->var_part2, + tob->tob_value, 0); + if (!rob) + { + if (Tcl_UnsetVar2(interp, var->var_name, 0, + TCL_LEAVE_ERR_MSG) == TCL_OK) + rob = Tcl_ObjSetVar2(interp, var->var_part1, var->var_part2, + tob->tob_value, TCL_LEAVE_ERR_MSG); + } + if (rob) + { +#ifdef PLUSTOT_DEBUGREFCOUNTS + if (var->var_index) + post("vv %x plusvar_postset [%s(%s)]", + (int)tob->tob_value, var->var_name, var->var_index); + else + post("vv %x plusvar_postset [%s]", + (int)tob->tob_value, var->var_name); +#endif + } + else plusloud_tclerror(0, interp, "cannot set variable"); + } + else + { + if (Tcl_UnsetVar2(interp, var->var_name, 0, + TCL_LEAVE_ERR_MSG) != TCL_OK) + plusloud_tclerror(0, interp, "cannot unset variable"); + rob = 0; + } + Tcl_Release(interp); + return (rob); +} + +Tcl_Obj *plusvar_push(t_plusvar *var) +{ + if (((t_plustob *)var)->tob_value) + return (plusvar_postset(var)); + else + return (0); +} + +Tcl_Obj *plusvar_pull(t_plusvar *var) +{ + Tcl_Obj *rob; + t_plustob *tob = (t_plustob *)var; + Tcl_Interp *interp = tob->tob_tin->tin_interp; + Tcl_Preserve(interp); + if (rob = Tcl_ObjGetVar2(interp, var->var_part1, var->var_part2, + TCL_LEAVE_ERR_MSG)) + plustob_set(tob, tob->tob_tin, rob); + else + plusloud_tclerror(0, interp, "cannot read variable"); + Tcl_Release(interp); + return (rob); +} + +Tcl_Obj *plusvar_set(t_plusvar *var, Tcl_Obj *ob, int doit) +{ + t_plustob *tob = (t_plustob *)var; + if (plustob_set(tob, tob->tob_tin, ob)) + return (doit ? plusvar_postset(var) : tob->tob_value); + else + return (0); +} + +Tcl_Obj *plusvar_setfloat(t_plusvar *var, t_float f, int doit) +{ + t_plustob *tob = (t_plustob *)var; + if (plustob_setfloat(tob, f)) + return (doit ? plusvar_postset(var) : tob->tob_value); + else + return (0); +} + +Tcl_Obj *plusvar_setsymbol(t_plusvar *var, t_symbol *s, int doit) +{ + t_plustob *tob = (t_plustob *)var; + if (plustob_setsymbol(tob, s)) + return (doit ? plusvar_postset(var) : tob->tob_value); + else + return (0); +} + +Tcl_Obj *plusvar_setlist(t_plusvar *var, int ac, t_atom *av, int doit) +{ + t_plustob *tob = (t_plustob *)var; + if (plustob_setlist(tob, ac, av)) + return (doit ? plusvar_postset(var) : tob->tob_value); + else + return (0); +} + +/* LATER derive +string from +bob */ + +typedef struct _plusstring +{ + int ps_len; + char *ps_buf; + int ps_refcount; +} t_plusstring; + +/* Resolving dot-separators, unless script is empty. */ +t_plusstring *plusstring_fromatoms(int ac, t_atom *av, t_scriptlet *script) +{ + t_plusstring *ps = 0; + char *buf; + int length; + if (script) + { + char *start; + scriptlet_reset(script); + scriptlet_add(script, 1, 1, ac, av); + start = scriptlet_getcontents(script, &length); + buf = copybytes(start, length); + } + else + { + char *newbuf; + buf = getbytes(0); + length = 0; + while (ac--) + { + char string[MAXPDSTRING]; + int newlength; + if ((av->a_type == A_SEMI || av->a_type == A_COMMA) && + length && buf[length-1] == ' ') length--; + atom_string(av, string, MAXPDSTRING); + newlength = length + strlen(string) + 1; + if (!(newbuf = resizebytes(buf, length, newlength))) break; + buf = newbuf; + strcpy(buf + length, string); + length = newlength; + if (av->a_type == A_SEMI) buf[length-1] = '\n'; + else buf[length-1] = ' '; + av++; + } + if (length && buf[length-1] == ' ') + { + if (newbuf = resizebytes(buf, length, length-1)) + { + buf = newbuf; + length--; + } + } + } + ps = getbytes(sizeof(*ps)); + ps->ps_len = length; + ps->ps_buf = buf; + ps->ps_refcount = 0; + return (ps); +} + +void plusstring_preserve(t_plusstring *ps) +{ + ps->ps_refcount++; +} + +void plusstring_release(t_plusstring *ps) +{ + if (--ps->ps_refcount <= 0) + { + if (ps->ps_refcount == 0) + { + if (ps->ps_buf) freebytes(ps->ps_buf, ps->ps_len); + freebytes(ps, sizeof(*ps)); + } + else bug("plusstring_release"); + } +} + +typedef struct _plusword +{ + int pw_type; + Tcl_Obj *pw_ob; + Tcl_Token *pw_ndxv; /* index part of this word (if array variable) */ + int pw_ndxc; /* numComponents of the above */ +} t_plusword; + +#define PLUSTOT_MAXINLETS 256 /* LATER rethink */ +#define PLUSTOT_INIMAXWORDS 16 + +/* LATER elaborate */ +#define PLUSTOT_ERRUNKNOWN -1 +#define PLUSTOT_ERROTHER -2 + +typedef struct _plusproxy +{ + t_pd pp_pd; + t_pd *pp_master; + t_plusvar *pp_var; + int pp_ndx; + int pp_doit; + int pp_warned; +} t_plusproxy; + +typedef struct _plustot +{ + t_object x_ob; + t_glist *x_glist; + t_plustob *x_tob; /* interpreter's result (after invocation) */ + t_scriptlet *x_script; + Tcl_Obj *x_cname; /* command name, main validation flag */ + Tcl_CmdInfo x_cinfo; + t_plusstring *x_ctail; /* command arguments, parse validation flag */ + Tcl_Parse x_tailparse; + int x_maxwords; /* as allocated */ + int x_nwords; /* as used, including command name */ + t_plusword *x_words; /* arguments, not evaluated */ + t_plusword x_wordsini[PLUSTOT_INIMAXWORDS]; + int x_maxargs; /* == maxwords, except during growing */ + int x_argc; /* 0 or nwords, except during evaluation */ + Tcl_Obj **x_argv; /* command name and evaluated arguments */ + Tcl_Obj *x_argvini[PLUSTOT_INIMAXWORDS]; + int x_pseudoscalar; + int x_nproxies; + t_plusproxy **x_proxies; + t_plusproxy *x_mainproxy; /* == x_proxies[0], unless pseudo-scalar */ + int x_grabwarned; +} t_plustot; + +static t_class *plusproxy_class; +static t_class *plustot_class; + +/* Create a variable here only for the main slot. Other slots are to be + filled during the second parsing pass, in order to fill only the slots + that are actually referenced. If ndx is negative, then create + a pseudo-scalar, otherwise this is a pseudo-array element. */ +static t_plusproxy *plusproxy_new(t_pd *master, int ndx, t_plustin *tin) +{ + t_plusproxy *pp = (t_plusproxy *)pd_new(plusproxy_class); + pp->pp_master = master; + pp->pp_var = (ndx > 0 ? 0 : plusvar_new("in", (ndx ? 0 : "0"), tin)); + if (pp->pp_var) + { + plusbob_preserve((t_plusbob *)pp->pp_var); + plusbob_setowner((t_plusbob *)pp->pp_var, master); + } + pp->pp_ndx = ndx; + pp->pp_doit = (ndx < 1); + pp->pp_warned = 0; + return (pp); +} + +static void plusproxy_free(t_plusproxy *pp) +{ +#ifdef PLUSTOT_DEBUG + post("plusproxy_free (%s %d)", + (pp->pp_var ? pp->pp_var->var_name : "empty"), pp->pp_ndx); +#endif + if (pp->pp_var) + plusbob_release((t_plusbob *)pp->pp_var); +} + +static void plusproxy_emptyhit(t_plusproxy *pp) +{ + if (!pp->pp_warned) + { + loud_error(pp->pp_master, "empty slot hit"); + pp->pp_warned = 1; + } +} + +static void plusproxy_bang(t_plusproxy *pp) +{ + if (pp->pp_var) + plusvar_push(pp->pp_var); + else + plusproxy_emptyhit(pp); +} + +static void plusproxy_float(t_plusproxy *pp, t_float f) +{ + if (pp->pp_var) + plusvar_setfloat(pp->pp_var, f, pp->pp_doit); + else + plusproxy_emptyhit(pp); +} + +static void plusproxy_symbol(t_plusproxy *pp, t_symbol *s) +{ + if (pp->pp_var) + plusvar_setsymbol(pp->pp_var, s, pp->pp_doit); + else + plusproxy_emptyhit(pp); +} + +static void plusproxy_list(t_plusproxy *pp, t_symbol *s, int ac, t_atom *av) +{ + if (pp->pp_var) + plusvar_setlist(pp->pp_var, ac, av, pp->pp_doit); + else + plusproxy_emptyhit(pp); +} + +#ifdef PLUSTOT_DEBUG +static void plusproxy_debug(t_plusproxy *pp) +{ + t_plustin *tin = ((t_plustob *)pp->pp_var)->tob_tin; + t_symbol *id = plusenv_getid((t_plusenv *)tin); + t_symbol *glname = plustin_getglistname(tin); + post("+proxy %d, glist %x", + pp->pp_ndx, (int)((t_plustot *)pp->pp_master)->x_glist); + post(" plustin '%s' (%s) over %x", (id ? id->s_name : "default"), + (glname ? glname->s_name : "<anonymous>"), (int)tin->tin_interp); +} +#endif + +/* First pass (!doit): determine number of slots. + Second pass (doit): create variables for non-empty slots. */ +static int plustot_usevariable(t_plustot *x, Tcl_Token *tp, int doit) +{ + int nc = tp->numComponents; + char *errmess = 0; + int errcode = PLUSTOT_ERRUNKNOWN; +#ifdef PLUSTOT_DEBUG + if (!doit) + { + char buf[MAXPDSTRING]; + int size = tp->size; + if (size > (MAXPDSTRING-2)) + { + size = (MAXPDSTRING-2); + buf[MAXPDSTRING-2] = '*'; + buf[MAXPDSTRING-1] = 0; + } + else buf[size] = 0; + strncpy(buf, tp->start, size); + startpost("%s ", buf); + } +#endif + tp++; + if (nc && tp->type == TCL_TOKEN_TEXT) + { + if (strncmp(tp->start, "in", tp->size)) + { + /* regular variable */ + /* LATER consider tracing it (2nd pass) */ + } + else + { + /* pseudo-variable */ + int inno = -1; + tp++; + if (nc == 1) + { + if (x->x_nproxies && !x->x_pseudoscalar) + { + errmess = "mixed scalar and array forms of pseudo-variable"; + errcode = PLUSTOT_ERROTHER; + goto badvariable; + } + inno = 0; + x->x_pseudoscalar = 1; + } + else if (nc == 2 && tp->type == TCL_TOKEN_TEXT) + { + int i; + char *p; + if (x->x_pseudoscalar) + { + errmess = "mixed scalar and array forms of pseudo-variable"; + errcode = PLUSTOT_ERROTHER; + goto badvariable; + } + inno = 0; + for (i = 0, p = (char *)tp->start; i < tp->size; i++, p++) + { + if (*p < '0' || *p > '9') + { + errmess = "invalid inlet number in pseudo-variable"; + errcode = PLUSTOT_ERROTHER; + goto badvariable; + } + inno = inno * 10 + (int)(*p - '0'); + } + if (inno > PLUSTOT_MAXINLETS) + { + errmess = "inlet number too large in pseudo-variable"; + errcode = PLUSTOT_ERROTHER; + goto badvariable; + } + } + else + { + errmess = "invalid index format in pseudo-variable"; + errcode = PLUSTOT_ERROTHER; + goto badvariable; + } + if (inno >= 0) + { + if (!doit) + { +#ifdef PLUSTOT_DEBUG + startpost("(inlet %d) ", inno); +#endif + if (inno >= x->x_nproxies) + x->x_nproxies = inno + 1; + } + else if (inno < x->x_nproxies) + { + if (inno > 0 && !x->x_proxies[inno]->pp_var) + { + t_plusvar *var; + char buf[8]; + sprintf(buf, "%d", inno); + var = plusvar_new("in", buf, x->x_tob->tob_tin); + plusbob_preserve((t_plusbob *)var); + plusbob_setowner((t_plusbob *)var, (t_pd *)x); + x->x_proxies[inno]->pp_var = var; + } + } + else + { + PLUSDEBUG_ENDPOST("plustot_usevariable"); + bug("plustot_usevariable"); + goto badvariable; + } + } + else + { + errmess = "invalid pseudo-variable"; + errcode = PLUSTOT_ERROTHER; + goto badvariable; + } + } + return (1); + } + else plusloud_tcldirty((t_pd *)x, "plustot_usevariable"); +badvariable: + if (errmess) + { + PLUSDEBUG_ENDPOST("plustot_usevariable"); + loud_error((t_pd *)x, errmess); + } + return (errcode); +} + +static int plustot_doparsevariables(t_plustot *x, Tcl_Interp *interp, + const char *buf, int len, + Tcl_Parse *parsep, int doit) +{ + int nvars = 0; + int errcode = PLUSTOT_ERRUNKNOWN; + if (Tcl_ParseCommand(interp, buf, len, 0, parsep) == TCL_OK) + { + int ntok = parsep->numTokens; + Tcl_Token *tp = parsep->tokenPtr; + while (ntok--) + { + if (tp->type == TCL_TOKEN_VARIABLE) + { + int res = plustot_usevariable(x, tp, doit); + if (res > 0) + nvars++; + else + { + errcode = res; + goto parsefailed; + } + } + else if (tp->type == TCL_TOKEN_COMMAND) + { + if (tp->size > 2) + { + Tcl_Parse parse; + int res = + plustot_doparsevariables(x, interp, tp->start + 1, + tp->size - 2, &parse, doit); + if (res != PLUSTOT_ERRUNKNOWN) + Tcl_FreeParse(&parse); + if (res >= 0) + nvars += res; + else + { + errcode = res; + goto parsefailed; + } + } + } + else if (tp->type == TCL_TOKEN_SIMPLE_WORD + && tp->size > 2 && *tp->start == '{') + { + tp++; +#if 0 && defined(PLUSTOT_DEBUG) + if (doit && tp->size > 0) + { + char buf[MAXPDSTRING+1]; + int sz = (tp->size < MAXPDSTRING ? tp->size : MAXPDSTRING); + strncpy(buf, tp->start, sz); + buf[sz] = 0; + post("simple word's text: %s", buf); + } +#endif + if (ntok-- && tp->type == TCL_TOKEN_TEXT && tp->size > 0) + { + Tcl_Parse parse; + int res = + plustot_doparsevariables(x, interp, tp->start, + tp->size, &parse, doit); + if (res != PLUSTOT_ERRUNKNOWN) + Tcl_FreeParse(&parse); + if (res >= 0) + nvars += res; + else + { + errcode = res; + goto parsefailed; + } + } + else + { + plusloud_tcldirty((t_pd *)x, "plustot_doparsevariables"); + goto parsefailed; + } + } +#if 0 && defined(PLUSTOT_DEBUG) + else if (doit && tp->size > 0) + { + char buf[MAXPDSTRING+1]; + int sz = (tp->size < MAXPDSTRING ? tp->size : MAXPDSTRING); + strncpy(buf, tp->start, sz); + buf[sz] = 0; + post("other type (%d): %s", tp->type, buf); + } +#endif + tp++; + } + } + else goto parsefailed; + return (nvars); +parsefailed: + return (errcode); +} + +static int plustot_parsevariables(t_plustot *x, Tcl_Interp *interp, + const char *buf, int len, + Tcl_Parse *parsep, int doit) +{ + int nvars; +#ifdef PLUSTOT_DEBUG + if (!doit) startpost("variables: "); +#endif + nvars = plustot_doparsevariables(x, interp, buf, len, parsep, doit); +#ifdef PLUSTOT_DEBUG + if (!doit) + { + if (nvars > 0) + { + post("\n%d variable substitutions", nvars); + post("%d inlets requested", x->x_nproxies); + } + else if (nvars == 0) post("none"); + } +#endif + return (nvars); +} + +static int plustot_makeproxies(t_plustot *x) +{ + Tcl_Interp *interp = x->x_tob->tob_tin->tin_interp; + if (interp) + { + if (x->x_nproxies == 1) + { + x->x_mainproxy = + plusproxy_new((t_pd *)x, (x->x_pseudoscalar ? -1 : 0), + x->x_tob->tob_tin); + } + else if (x->x_nproxies > 1 && !x->x_pseudoscalar) + { + if (x->x_proxies = getbytes(x->x_nproxies * sizeof(*x->x_proxies))) + { + int i; + for (i = 0; i < x->x_nproxies; i++) + x->x_proxies[i] = + plusproxy_new((t_pd *)x, i, x->x_tob->tob_tin); + for (i = 1; i < x->x_nproxies; i++) + inlet_new((t_object *)x, (t_pd *)x->x_proxies[i], 0, 0); + x->x_mainproxy = x->x_proxies[0]; + /* second pass: traverse non-empty slots, create variables */ + plustot_parsevariables(x, interp, + x->x_ctail->ps_buf, x->x_ctail->ps_len, + &x->x_tailparse, 1); + } + else goto proxiesfailed; + } + else + { + bug("plustot_makeproxies"); + goto proxiesfailed; + } + return (1); + } +proxiesfailed: + return (0); +} + +static void plustot_initwords(t_plustot *x) +{ + if (x->x_words != x->x_wordsini) + freebytes(x->x_words, x->x_maxwords * sizeof(*x->x_words)); + x->x_maxwords = PLUSTOT_INIMAXWORDS; + x->x_nwords = 0; + x->x_words = x->x_wordsini; +} + +static void plustot_initargs(t_plustot *x) +{ + if (x->x_argv != x->x_argvini) + freebytes(x->x_argv, x->x_maxargs * sizeof(*x->x_argv)); + x->x_maxargs = PLUSTOT_INIMAXWORDS; + x->x_argc = 0; + x->x_argv = x->x_argvini; + x->x_argv[0] = x->x_cname; +} + +static int plustot_resetwords(t_plustot *x) +{ + int i; + for (i = 1; i < x->x_nwords; i++) + PLUSDEBUG_DECRREFCOUNT(x->x_words[i].pw_ob, "plustot_resetwords"); + x->x_nwords = 0; + if (x->x_ctail) + { + int nwords = x->x_tailparse.numWords + 1; + if (nwords > x->x_maxwords) + { + int n = nwords; +#ifdef PLUSTOT_DEBUG + post("growing words %d -> %d", x->x_maxwords, nwords); +#endif + x->x_words = grow_nodata(&n, &x->x_maxwords, x->x_words, + PLUSTOT_INIMAXWORDS, x->x_wordsini, + sizeof(*x->x_words)); + if (n != nwords) + return (0); + } + return (1); + } + else return (0); +} + +static int plustot_resetargs(t_plustot *x) +{ + int i; + for (i = 1; i < x->x_argc; i++) + PLUSDEBUG_DECRREFCOUNT(x->x_argv[i], "plustot_resetargs"); + x->x_argc = 0; + x->x_argv[0] = x->x_cname; + if (x->x_ctail) + { + int nargs = x->x_maxwords; + if (nargs > x->x_maxargs) + { + int n = nargs; +#ifdef PLUSTOT_DEBUG + post("growing argv %d -> %d", x->x_maxargs, nargs); +#endif + x->x_argv = grow_nodata(&n, &x->x_maxargs, x->x_argv, + PLUSTOT_INIMAXWORDS, x->x_argvini, + sizeof(*x->x_argv)); + x->x_argv[0] = x->x_cname; + if (n != nargs) + { + plustot_initwords(x); + plustot_initargs(x); + return (0); + } + } + else if (nargs < x->x_maxargs) + { + bug("plustot_resetargs"); /* LATER rethink */ + plustot_initwords(x); + plustot_initargs(x); + return (0); + } + return (1); + } + else return (0); +} + +static int plustot_makewords(t_plustot *x) +{ + if (plustot_resetwords(x)) + { + int i, ncomponents = 0, nwords = x->x_tailparse.numWords + 1; + Tcl_Token *tp; + int len; + char buf[TCL_UTF_MAX]; +#ifdef PLUSTOT_DEBUG + post("arguments:"); +#endif + for (i = 1, tp = x->x_tailparse.tokenPtr; + i < nwords; i++, tp += ncomponents) + { +#ifdef PLUSTOT_DEBUG + post(" %s token: type %d[%d], having %d[%d] component%s", + loud_ordinal(i), tp->type, tp[1].type, + tp->numComponents, tp[1].numComponents, + (tp->numComponents > 1 ? "s" : "")); +#endif + ncomponents = tp->numComponents; + tp++; + switch (x->x_words[i].pw_type = tp->type) + { + case TCL_TOKEN_TEXT: + x->x_words[i].pw_ob = Tcl_NewStringObj(tp->start, tp->size); + break; + + case TCL_TOKEN_BS: + len = Tcl_UtfBackslash(tp->start, 0, buf); + x->x_words[i].pw_ob = Tcl_NewStringObj(buf, len); + break; + + case TCL_TOKEN_COMMAND: + x->x_words[i].pw_ob = Tcl_NewStringObj(tp->start + 1, + tp->size - 2); + break; + + case TCL_TOKEN_VARIABLE: + if (tp->numComponents > 1) + { + x->x_words[i].pw_ndxv = tp + 2; + x->x_words[i].pw_ndxc = tp->numComponents - 1; + } + else x->x_words[i].pw_ndxv = 0; + x->x_words[i].pw_ob = Tcl_NewStringObj(tp[1].start, tp[1].size); + break; + + default: + plusloud_tcldirty((t_pd *)x, + "plustot_makewords (unexpected token type)"); + goto wordsfailed; + } + PLUSDEBUG_INCRREFCOUNT(x->x_words[i].pw_ob, "plustot_makewords"); + } + x->x_nwords = nwords; + return (1); +wordsfailed: + x->x_nwords = i; + plustot_resetwords(x); + } + return (0); +} + +static int plustot_argsfromwords(t_plustot *x, Tcl_Interp *interp) +{ + if (plustot_resetargs(x)) + { + t_plusword *pw; + int i; + for (i = 1, pw = &x->x_words[1]; i < x->x_nwords; i++, pw++) + { + int result; + if (pw->pw_type == TCL_TOKEN_COMMAND) + { + result = Tcl_EvalObjEx(interp, pw->pw_ob, 0); + if (result == TCL_OK) + { + if (x->x_argv[i] = Tcl_GetObjResult(interp)) + { + PLUSDEBUG_INCRREFCOUNT(x->x_argv[i], + "plustot_argsfromwords"); + Tcl_ResetResult(interp); + } + else + { + plusloud_tcldirty((t_pd *)x, "plustot_argsfromwords"); + goto evalfailed; + } + } + else + { + plusloud_tclerror((t_pd *)x, interp, "bad word (command)"); + goto evalfailed; + } + } + else if (pw->pw_type == TCL_TOKEN_VARIABLE) + { + Tcl_Obj *indexp; + if (x->x_words[i].pw_ndxv) + { + /* FIXME */ + int res = Tcl_EvalTokensStandard(interp, + x->x_words[i].pw_ndxv, + x->x_words[i].pw_ndxc); + if (res == TCL_OK) + { + indexp = Tcl_GetObjResult(interp); + PLUSDEBUG_INCRREFCOUNT(indexp, + "plustot_argsfromwords"); + Tcl_ResetResult(interp); + } + else + { + plusloud_tclerror((t_pd *)x, interp, "bad index"); + goto evalfailed; + } + } + else indexp = 0; + if (x->x_argv[i] = Tcl_ObjGetVar2(interp, pw->pw_ob, indexp, + TCL_LEAVE_ERR_MSG)) + { + PLUSDEBUG_INCRREFCOUNT(x->x_argv[i], + "plustot_argsfromwords"); + Tcl_ResetResult(interp); + } + else + { + plusloud_tclerror((t_pd *)x, interp, "bad word (variable)"); + goto evalfailed; + } + } + else + { + x->x_argv[i] = pw->pw_ob; + /* refcount is 1 already (makewords), but we need to comply to + a general rule: args are decremented after use (resetargs) */ + PLUSDEBUG_INCRREFCOUNT(x->x_argv[i], "plustot_argsfromwords"); + } + } + x->x_argc = x->x_nwords; + return (1); +evalfailed: + x->x_argc = i; + plustot_resetargs(x); + } + return (0); /* LATER find a proper way for passing a result */ +} + +static int plustot_argsfromtokens(t_plustot *x, Tcl_Interp *interp) +{ + if (plustot_resetargs(x)) + { + int i, nwords = x->x_tailparse.numWords + 1; + Tcl_Token *tp; +#ifdef PLUSTOT_DEBUG + post("arguments:"); +#endif + for (i = 1, tp = x->x_tailparse.tokenPtr; + i < nwords; i++, tp += (tp->numComponents + 1)) + { + int result; +#ifdef PLUSTOT_DEBUG + startpost(" %s token: type %d[%d], having %d component%s", + loud_ordinal(i), tp->type, tp[1].type, + tp->numComponents, (tp->numComponents > 1 ? "s" : "")); +#endif + result = Tcl_EvalTokensStandard(interp, tp + 1, tp->numComponents); + if (result == TCL_OK) + { + if (x->x_argv[i] = Tcl_GetObjResult(interp)) + { + PLUSDEBUG_INCRREFCOUNT(x->x_argv[i], + "plustot_argsfromwords"); + Tcl_ResetResult(interp); +#ifdef PLUSTOT_DEBUG + post(", %sshared: '%s'", + (Tcl_IsShared(x->x_argv[i]) ? "" : "not "), + Tcl_GetString(x->x_argv[i])); +#endif + } + else + { + PLUSDEBUG_ENDPOST("plustot_argsfromtokens"); + plusloud_tcldirty((t_pd *)x, "plustot_argsfromtokens"); + } + } + else + { + PLUSDEBUG_ENDPOST("plustot_argsfromtokens"); + plusloud_tclerror((t_pd *)x, interp, "bad token"); + while (--i) + PLUSDEBUG_DECRREFCOUNT(x->x_argv[i], + "plustot_argsfromtokens"); + return (0); /* LATER find a proper way for passing a result */ + } + } + x->x_argc = nwords; + return (1); + } + else return (0); +} + +/* not used yet */ +static int plustot_ifgrabshared(t_plustot *x, Tcl_Obj *ob) +{ + if (!x->x_grabwarned) + { + x->x_grabwarned = 1; + loud_warning((t_pd *)x, "shared result of a command '%s'", + (x->x_cname ? Tcl_GetString(x->x_cname) : "???")); + } + return (1); +} + +static int plustot_push(t_plustot *x) +{ + if (x->x_proxies) + { + int i; + for (i = 1; i < x->x_nproxies; i++) + if (x->x_proxies[i]->pp_var) + if (!plusvar_push(x->x_proxies[i]->pp_var)) + return (0); + } + return (1); +} + +static int plustot_doit(t_plustot *x) +{ + int result = 0; + Tcl_Interp *interp = x->x_tob->tob_tin->tin_interp; + if (x->x_cname && plustot_push(x) && + plustot_argsfromwords(x, interp)) + { + if ((*x->x_cinfo.objProc)(x->x_cinfo.objClientData, interp, + x->x_argc, x->x_argv) == TCL_OK) + { + if (plustob_grabresult(x->x_tob)) + result = 1; + } + else plusloud_tclerror((t_pd *)x, interp, "command failed"); + /* Although args are to be reset in the next call to + plustot_argsfromwords(), however, plusvar_preset() will be called + first, so, unless reset is done here, $ins would be shared there. + LATER rethink. */ + plustot_resetargs(x); + } + return (result); +} + +static void plustot_eval(t_plustot *x) +{ + plustot_doit(x); +} + +static void plustot_get(t_plustot *x) +{ + if (x->x_tob->tob_value) + outlet_plusbob(((t_object *)x)->ob_outlet, (t_plusbob *)x->x_tob); +} + +/* set in(0), no evaluation */ +static void plustot_set(t_plustot *x, t_symbol *s, int ac, t_atom *av) +{ + if (x->x_mainproxy) + { + if (ac == 1) + { + if (av->a_type == A_FLOAT) + plusproxy_float(x->x_mainproxy, av->a_w.w_float); + else if (av->a_type == A_SYMBOL) + plusproxy_symbol(x->x_mainproxy, av->a_w.w_symbol); + } + else plusproxy_list(x->x_mainproxy, s, ac, av); + } +} + +static void plustot_bang(t_plustot *x) +{ + if (x->x_mainproxy) + plusproxy_bang(x->x_mainproxy); + if (plustot_doit(x)) + outlet_plusbob(((t_object *)x)->ob_outlet, (t_plusbob *)x->x_tob); +} + +static void plustot_float(t_plustot *x, t_float f) +{ + if (x->x_mainproxy) + plusproxy_float(x->x_mainproxy, f); + if (plustot_doit(x)) + outlet_plusbob(((t_object *)x)->ob_outlet, (t_plusbob *)x->x_tob); +} + +static void plustot_symbol(t_plustot *x, t_symbol *s) +{ + if (x->x_mainproxy) + plusproxy_symbol(x->x_mainproxy, s); + if (plustot_doit(x)) + outlet_plusbob(((t_object *)x)->ob_outlet, (t_plusbob *)x->x_tob); +} + +static void plustot_list(t_plustot *x, t_symbol *s, int ac, t_atom *av) +{ + if (x->x_mainproxy) + plusproxy_list(x->x_mainproxy, s, ac, av); + if (plustot_doit(x)) + outlet_plusbob(((t_object *)x)->ob_outlet, (t_plusbob *)x->x_tob); +} + +static void plustot_tot(t_plustot *x, t_symbol *s, int ac, t_atom *av) +{ + if (ac) + { + Tcl_Obj *ob; + char *start; + int len; + scriptlet_reset(x->x_script); + scriptlet_add(x->x_script, 1, 1, ac, av); + start = scriptlet_getcontents(x->x_script, &len); + if (len > 0 && (ob = Tcl_NewStringObj(start, len))) + { + /* LATER set a persistent ob, rather than create a new one */ + PLUSDEBUG_INCRREFCOUNT(ob, "plustot_tot"); + if (plustob_evalob(x->x_tob, ob) && s == totps_query) + outlet_plusbob(((t_object *)x)->ob_outlet, + (t_plusbob *)x->x_tob); + PLUSDEBUG_DECRREFCOUNT(ob, "plustot_tot"); + } + } +} + +#ifdef PLUSTOT_DEBUG +static void plustot_debug(t_plustot *x) +{ + t_plustin *tin = x->x_tob->tob_tin; + t_symbol *id = plusenv_getid((t_plusenv *)tin); + t_symbol *glname = plustin_getglistname(tin); + post("+tot, glist %x", (int)x->x_glist); + post(" plustin '%s' (%s) over %x", (id ? id->s_name : "default"), + (glname ? glname->s_name : "<anonymous>"), (int)tin->tin_interp); + if (x->x_mainproxy) + plusproxy_debug(x->x_mainproxy); +} +#endif + +static void plustot_free(t_plustot *x) +{ + int i; + plusbob_release((t_plusbob *)x->x_tob); + if (x->x_cname) PLUSDEBUG_DECRREFCOUNT(x->x_cname, "plustot_free"); + if (x->x_ctail) + { + for (i = 1; i < x->x_nwords; i++) + PLUSDEBUG_DECRREFCOUNT(x->x_words[i].pw_ob, "plustot_free"); + for (i = 1; i < x->x_argc; i++) + PLUSDEBUG_DECRREFCOUNT(x->x_argv[i], "plustot_free"); + if (x->x_words != x->x_wordsini) + freebytes(x->x_words, x->x_maxwords * sizeof(*x->x_words)); + if (x->x_argv != x->x_argvini) + freebytes(x->x_argv, x->x_maxwords * sizeof(*x->x_argv)); + Tcl_FreeParse(&x->x_tailparse); + plusstring_release(x->x_ctail); + } + if (x->x_mainproxy) pd_free((t_pd *)x->x_mainproxy); + if (x->x_proxies) + { + for (i = 1; i < x->x_nproxies; i++) + pd_free((t_pd *)x->x_proxies[i]); + freebytes(x->x_proxies, x->x_nproxies * sizeof(*x->x_proxies)); + } + if (x->x_script) scriptlet_free(x->x_script); +} + +static void *plustot_new(t_symbol *s, int ac, t_atom *av) +{ + t_plustot *x = 0; + t_plusstring *ctail = 0; + t_symbol *cmdname = 0; /* command name or +selector */ + t_glist *glist = canvas_getcurrent(); + t_plustin *tin = 0; + t_plustob *tob = 0; + t_scriptlet *script = scriptlet_new(0, 0, 0, 0, glist, 0); + if (ac && av->a_type == A_SYMBOL) + { + cmdname = av->a_w.w_symbol; + ac--; av++; + if (*cmdname->s_name == '+') + { + if (cmdname == plusps_env) + return (plustot_env_new(cmdname, ac, av)); + else if (cmdname == plusps_in) + return (plustot_in_new(cmdname, ac, av)); + else if (cmdname == plusps_var) + return (plustot_var_new(cmdname, ac, av)); + else if (cmdname == plusps_out) + return (plustot_out_new(cmdname, ac, av)); + else if (cmdname == plusps_qlist) + return (plustot_qlist_new(cmdname, ac, av)); + else if (cmdname == plusps_print) + return (plustot_print_new(cmdname, ac, av)); + else + { + loud_error(0, "unknown +tot's subclass"); + return (0); + } + } + if (ac) + { + ctail = plusstring_fromatoms(ac, av, script); + plusstring_preserve(ctail); + } + } + if ((tin = plustin_glistprovide(glist, PLUSTIN_GLIST_ANY, 0)) && + (tob = plustob_new(tin, 0))) + { + x = (t_plustot *)pd_new(plustot_class); + /* tin already preserved (plustob_new() did it) */ + plusbob_preserve((t_plusbob *)tob); + plusbob_setowner((t_plusbob *)tob, (t_pd *)x); + x->x_glist = glist; + x->x_tob = tob; + scriptlet_setowner(script, (t_pd *)x); + x->x_script = script; + x->x_cname = 0; + x->x_ctail = 0; + x->x_words = x->x_wordsini; + plustot_initwords(x); + x->x_argv = x->x_argvini; + plustot_initargs(x); + x->x_pseudoscalar = 0; + x->x_nproxies = 0; + x->x_proxies = 0; + x->x_mainproxy = 0; + x->x_grabwarned = 0; + if (cmdname && *cmdname->s_name) + { + Tcl_Interp *interp = tin->tin_interp; + if (interp) + { + if (Tcl_GetCommandInfo(interp, cmdname->s_name, &x->x_cinfo)) + { + if (x->x_cinfo.isNativeObjectProc) + { + x->x_cname = Tcl_NewStringObj(cmdname->s_name, -1); + PLUSDEBUG_INCRREFCOUNT(x->x_cname, "plustot_new"); + x->x_argv[0] = x->x_cname; + } + else loud_error((t_pd *)x, "'%s' is not an object command", + cmdname->s_name); + } + else loud_error((t_pd *)x, "command '%s' does not exist", + cmdname->s_name); + if (x->x_cname && ctail) + { + int nvars = + plustot_parsevariables(x, interp, + ctail->ps_buf, ctail->ps_len, + &x->x_tailparse, 0); + if (nvars >= 0) + { + int res = 1; + x->x_ctail = ctail; + if (x->x_nproxies) + res = plustot_makeproxies(x); + if (res) + res = plustot_makewords(x); + if (!res) + x->x_ctail = 0; + Tcl_FreeParse(&x->x_tailparse); + } + else + { + if (nvars == PLUSTOT_ERRUNKNOWN) + plusloud_tclerror((t_pd *)x, interp, + "parsing command arguments failed"); + else + Tcl_FreeParse(&x->x_tailparse); + PLUSDEBUG_DECRREFCOUNT(x->x_cname, "plustot_new"); + x->x_cname = 0; + } + } + } + } + outlet_new((t_object *)x, &s_symbol); + } + else + { + loud_error(0, "+tot: cannot initialize"); + if (tin) + { + plusbob_preserve((t_plusbob *)tin); + plusbob_release((t_plusbob *)tin); + } + if (script) scriptlet_free(script); + } + if (ctail && !(x && x->x_ctail)) + plusstring_release(ctail); + return (x); +} + +void plustot_setup(void) +{ + post("beware! this is plustot %s, %s %s build...", + TOXY_VERSION, loud_ordinal(TOXY_BUILD), TOXY_RELEASE); + plustot_class = class_new(gensym("+tot"), + (t_newmethod)plustot_new, + (t_method)plustot_free, + sizeof(t_plustot), 0, A_GIMME, 0); + class_addcreator((t_newmethod)plustot_new, + gensym("plustot"), A_GIMME, 0); + class_addbang(plustot_class, plustot_bang); + class_addfloat(plustot_class, plustot_float); + class_addsymbol(plustot_class, plustot_symbol); + class_addlist(plustot_class, plustot_list); + class_addmethod(plustot_class, (t_method)plustot_eval, + gensym("eval"), 0); + class_addmethod(plustot_class, (t_method)plustot_set, + gensym("set"), A_GIMME, 0); + class_addmethod(plustot_class, (t_method)plustot_get, + gensym("get"), 0); + class_addmethod(plustot_class, (t_method)plustot_tot, + gensym("tot"), A_GIMME, 0); + class_addmethod(plustot_class, (t_method)plustot_tot, + gensym("query"), A_GIMME, 0); +#ifdef PLUSTOT_DEBUG + class_addmethod(plustot_class, (t_method)plustot_debug, + gensym("debug"), 0); +#endif + + plusproxy_class = class_new(gensym("+tot proxy"), 0, + (t_method)plusproxy_free, + sizeof(t_plusproxy), CLASS_PD, 0); + class_addfloat(plusproxy_class, plusproxy_float); + class_addsymbol(plusproxy_class, plusproxy_symbol); + class_addlist(plusproxy_class, plusproxy_list); +#ifdef PLUSTOT_DEBUG + class_addmethod(plusproxy_class, (t_method)plusproxy_debug, + gensym("debug"), 0); +#endif + + plusps_tot = gensym("+tot"); + plusps_env = gensym("+env"); + plusps_in = gensym("+in"); + plusps_var = gensym("+var"); + plusps_out = gensym("+out"); + plusps_qlist = gensym("+qlist"); + plusps_print = gensym("+print"); + plusps_Ti = gensym("+Ti"); + plusps_To = gensym("+To"); + plusps_Tv = gensym("+Tv"); + totps_query = gensym("query"); + + plustin_basetype = plusenv_setup(); + plustin_type = plustype_new(plustin_basetype, plusps_Ti, + sizeof(t_plustin), + (t_plustypefn)plustin_delete, 0, 0, 0); + plustob_type = plustype_new(0, plusps_To, + sizeof(t_plustob), + (t_plustypefn)plustob_delete, 0, 0, + (t_plustypefn)plustob_attach); + plusvar_type = plustype_new(plustob_type, plusps_Tv, + sizeof(t_plusvar), + (t_plustypefn)plusvar_delete, 0, 0, 0); + + plustot_env_setup(); + plustot_in_setup(); + plustot_var_setup(); + plustot_out_setup(); + plustot_qlist_setup(); + plustot_print_setup(); +} |