Index: generic/nsf.c =================================================================== diff -u -r7def5bc35b6d31f0390d943d6d2221f8938b0e8a -r8040970d348ab537d9e3fefbc7f15d262ca52870 --- generic/nsf.c (.../nsf.c) (revision 7def5bc35b6d31f0390d943d6d2221f8938b0e8a) +++ generic/nsf.c (.../nsf.c) (revision 8040970d348ab537d9e3fefbc7f15d262ca52870) @@ -221,7 +221,9 @@ static Tcl_ObjCmdProc NsfObjscopedMethod; static Tcl_ObjCmdProc NsfSetterMethod; static Tcl_ObjCmdProc NsfProcAliasMethod; +static Tcl_ObjCmdProc NsfAsmProc; + /* prototypes for methods called directly when CallDirectly() returns NULL */ static int NsfCAllocMethod(Tcl_Interp *interp, NsfClass *cl, Tcl_Obj *nameObj); static int NsfCCreateMethod(Tcl_Interp *interp, NsfClass *cl, CONST char *name, int objc, Tcl_Obj *CONST objv[]); @@ -770,7 +772,6 @@ #include "nsfStack.c" - /*********************************************************************** * Value added replacements of Tcl functions ***********************************************************************/ @@ -9672,7 +9673,8 @@ } else if (proc == NsfForwardMethod || proc == NsfObjscopedMethod || - proc == NsfSetterMethod + proc == NsfSetterMethod || + proc == NsfAsmProc ) { TclCmdClientData *tcd = (TclCmdClientData *)cp; @@ -11950,7 +11952,7 @@ Tcl_PushCallFrame(interp, (Tcl_CallFrame *)framePtr, nsPtr, 0); /* create the method in the provided namespace */ - result = Tcl_ProcObjCmd(0, interp, 4, ov); + result = Tcl_ProcObjCmd(NULL, interp, 4, ov); if (result == TCL_OK) { /* retrieve the defined proc */ Proc *procPtr = FindProcMethod(nsPtr, methodName); @@ -12082,7 +12084,7 @@ } /************************************************************************** - * Begin Definition of Parameter procs (Tcl Procs with Parameter handling) + * Begin Definition of nsf::proc (Tcl Procs with Parameter handling) **************************************************************************/ /* *---------------------------------------------------------------------- @@ -12310,8 +12312,7 @@ * * TODO: the current 1 cmd + 1 proc implementation is not robust * against renaming and partial deletions (deletion of the - * stub). The sketched variant should be better and should be - * examined first in detail. + * stub). * * Results: * Tcl return code. @@ -12544,7 +12545,7 @@ return TCL_OK; } /************************************************************************** - * End Definition of Parameter procs (Tcl Procs with Parameter handling) + * End Definition of nsf::proc (Tcl Procs with Parameter handling) **************************************************************************/ /* @@ -17857,6 +17858,7 @@ return 0; } +#include "nsfAssemble.c" /*********************************************************************** * Begin generated Next Scripting commands @@ -18051,6 +18053,45 @@ } /* +cmd asmproc NsfAsmProcCmd { + {-argName "-ad" -required 0} + {-argName "procName" -required 1 -type tclobj} + {-argName "arguments" -required 1 -type tclobj} + {-argName "body" -required 1 -type tclobj} +} +*/ +static int +NsfAsmProcCmd(Tcl_Interp *interp, int with_ad, Tcl_Obj *nameObj, Tcl_Obj *arguments, Tcl_Obj *body) { + NsfParsedParam parsedParam; + int result; + /* + * Parse argument list "arguments" to determine if we should provide + * nsf parameter handling. + */ + result = ParamDefsParse(interp, nameObj, arguments, + NSF_DISALLOWED_ARG_METHOD_PARAMETER, 0, + &parsedParam); + if (result != TCL_OK) { + return result; + } + + if (parsedParam.paramDefs) { + /* + * We need parameter handling. + */ + result = NsfAsmProcAddParam(interp, &parsedParam, nameObj, body, with_ad); + + } else { + /* + * No parameter handling needed. + */ + result = NsfAsmProcAddArgs(interp, arguments, nameObj, body, with_ad); + } + + return result; +} + +/* cmd configure NsfConfigureCmd { {-argName "configureoption" -required 1 -type "debug|dtrace|filter|profile|softrecreate|objectsystems|keepinitcmd|checkresults|checkarguments"} {-argName "value" -required 0 -type tclobj} @@ -19772,13 +19813,13 @@ * later. */ result = NsfProcAdd(interp, &parsedParam, ObjStr(nameObj), body, with_ad); - + } else { /* * No parameter handling needed. A plain Tcl proc is added. */ Tcl_Obj *ov[4]; - + ov[0] = NULL; ov[1] = nameObj; ov[2] = arguments; Index: generic/nsfAPI.decls =================================================================== diff -u -r28648322161a72f3a5e0458fdefc110326322cba -r8040970d348ab537d9e3fefbc7f15d262ca52870 --- generic/nsfAPI.decls (.../nsfAPI.decls) (revision 28648322161a72f3a5e0458fdefc110326322cba) +++ generic/nsfAPI.decls (.../nsfAPI.decls) (revision 8040970d348ab537d9e3fefbc7f15d262ca52870) @@ -29,6 +29,13 @@ cmd __profile_get NsfProfileGetDataStub {} cmd __unset_unknown_args NsfUnsetUnknownArgsCmd {} +cmd "asm::proc" NsfAsmProcCmd { + {-argName "-ad" -required 0 -nrargs 0} + {-argName "procName" -required 1 -type tclobj} + {-argName "arguments" -required 1 -type tclobj} + {-argName "body" -required 1 -type tclobj} +} + cmd configure NsfConfigureCmd { {-argName "configureoption" -required 1 -type "debug|dtrace|filter|profile|softrecreate|objectsystems|keepinitcmd|checkresults|checkarguments"} {-argName "value" -required 0 -type tclobj} @@ -91,6 +98,17 @@ {-argName "-precondition" -type tclobj} {-argName "-postcondition" -type tclobj} } {-nxdoc 1} + +cmd method::asmcreate NsfAsmMethodCreateCmd { + {-argName "object" -required 1 -type object} + {-argName "-inner-namespace" -nrargs 0} + {-argName "-per-object" -nrargs 0} + {-argName "-reg-object" -required 0 -nrargs 1 -type object} + {-argName "name" -required 1 -type tclobj} + {-argName "arguments" -required 1 -type tclobj} + {-argName "body" -required 1 -type tclobj} +} + cmd "method::delete" NsfMethodDeleteCmd { {-argName "object" -required 1 -type object} {-argName "-per-object" -nrargs 0} @@ -173,6 +191,7 @@ {-argName "arguments" -required 1 -type tclobj} {-argName "body" -required 1 -type tclobj} } {-nxdoc 1} + cmd relation NsfRelationCmd { {-argName "object" -required 1 -type object} {-argName "relationtype" -required 1 -type "object-mixin|class-mixin|object-filter|class-filter|class|superclass|rootclass"} Index: generic/nsfAPI.h =================================================================== diff -u -r7def5bc35b6d31f0390d943d6d2221f8938b0e8a -r8040970d348ab537d9e3fefbc7f15d262ca52870 --- generic/nsfAPI.h (.../nsfAPI.h) (revision 7def5bc35b6d31f0390d943d6d2221f8938b0e8a) +++ generic/nsfAPI.h (.../nsfAPI.h) (revision 8040970d348ab537d9e3fefbc7f15d262ca52870) @@ -238,6 +238,8 @@ static int NsfClassInfoSlotobjectsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int NsfClassInfoSubclassMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int NsfClassInfoSuperclassMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int NsfAsmMethodCreateCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int NsfAsmProcCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int NsfColonCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int NsfConfigureCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int NsfCurrentCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -336,6 +338,8 @@ static int NsfClassInfoSlotobjectsMethod(Tcl_Interp *interp, NsfClass *cl, int withClosure, int withSource, NsfClass *withType, CONST char *pattern); static int NsfClassInfoSubclassMethod(Tcl_Interp *interp, NsfClass *cl, int withClosure, CONST char *patternString, NsfObject *patternObject); static int NsfClassInfoSuperclassMethod(Tcl_Interp *interp, NsfClass *cl, int withClosure, Tcl_Obj *pattern); +static int NsfAsmMethodCreateCmd(Tcl_Interp *interp, NsfObject *object, int withInner_namespace, int withPer_object, NsfObject *withReg_object, Tcl_Obj *name, Tcl_Obj *arguments, Tcl_Obj *body); +static int NsfAsmProcCmd(Tcl_Interp *interp, int withAd, Tcl_Obj *procName, Tcl_Obj *arguments, Tcl_Obj *body); static int NsfColonCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int NsfConfigureCmd(Tcl_Interp *interp, int configureoption, Tcl_Obj *value); static int NsfCurrentCmd(Tcl_Interp *interp, int currentoption); @@ -435,6 +439,8 @@ NsfClassInfoSlotobjectsMethodIdx, NsfClassInfoSubclassMethodIdx, NsfClassInfoSuperclassMethodIdx, + NsfAsmMethodCreateCmdIdx, + NsfAsmProcCmdIdx, NsfColonCmdIdx, NsfConfigureCmdIdx, NsfCurrentCmdIdx, @@ -1001,6 +1007,53 @@ } static int +NsfAsmMethodCreateCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + ParseContext pc; + (void)clientData; + + if (likely(ArgumentParse(interp, objc, objv, NULL, objv[0], + method_definitions[NsfAsmMethodCreateCmdIdx].paramDefs, + method_definitions[NsfAsmMethodCreateCmdIdx].nrParameters, 0, 1, + &pc) == TCL_OK)) { + NsfObject *object = (NsfObject *)pc.clientData[0]; + int withInner_namespace = (int )PTR2INT(pc.clientData[1]); + int withPer_object = (int )PTR2INT(pc.clientData[2]); + NsfObject *withReg_object = (NsfObject *)pc.clientData[3]; + Tcl_Obj *name = (Tcl_Obj *)pc.clientData[4]; + Tcl_Obj *arguments = (Tcl_Obj *)pc.clientData[5]; + Tcl_Obj *body = (Tcl_Obj *)pc.clientData[6]; + + assert(pc.status == 0); + return NsfAsmMethodCreateCmd(interp, object, withInner_namespace, withPer_object, withReg_object, name, arguments, body); + + } else { + return TCL_ERROR; + } +} + +static int +NsfAsmProcCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + ParseContext pc; + (void)clientData; + + if (likely(ArgumentParse(interp, objc, objv, NULL, objv[0], + method_definitions[NsfAsmProcCmdIdx].paramDefs, + method_definitions[NsfAsmProcCmdIdx].nrParameters, 0, 1, + &pc) == TCL_OK)) { + int withAd = (int )PTR2INT(pc.clientData[0]); + Tcl_Obj *procName = (Tcl_Obj *)pc.clientData[1]; + Tcl_Obj *arguments = (Tcl_Obj *)pc.clientData[2]; + Tcl_Obj *body = (Tcl_Obj *)pc.clientData[3]; + + assert(pc.status == 0); + return NsfAsmProcCmd(interp, withAd, procName, arguments, body); + + } else { + return TCL_ERROR; + } +} + +static int NsfColonCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { (void)clientData; @@ -2494,6 +2547,21 @@ {"-closure", 0, 0, Nsf_ConvertToString, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, {"pattern", 0, 1, Nsf_ConvertToTclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}} }, +{"::nsf::method::asmcreate", NsfAsmMethodCreateCmdStub, 7, { + {"object", NSF_ARG_REQUIRED, 1, Nsf_ConvertToObject, NULL,NULL,"object",NULL,NULL,NULL,NULL,NULL}, + {"-inner-namespace", 0, 0, Nsf_ConvertToString, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, + {"-per-object", 0, 0, Nsf_ConvertToString, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, + {"-reg-object", 0, 1, Nsf_ConvertToObject, NULL,NULL,"object",NULL,NULL,NULL,NULL,NULL}, + {"name", NSF_ARG_REQUIRED, 1, Nsf_ConvertToTclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, + {"arguments", NSF_ARG_REQUIRED, 1, Nsf_ConvertToTclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, + {"body", NSF_ARG_REQUIRED, 1, Nsf_ConvertToTclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}} +}, +{"::nsf::asm::proc", NsfAsmProcCmdStub, 4, { + {"-ad", 0, 0, Nsf_ConvertToString, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, + {"procName", NSF_ARG_REQUIRED, 1, Nsf_ConvertToTclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, + {"arguments", NSF_ARG_REQUIRED, 1, Nsf_ConvertToTclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}, + {"body", NSF_ARG_REQUIRED, 1, Nsf_ConvertToTclobj, NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}} +}, {"::nsf::colon", NsfColonCmdStub, 1, { {"args", 0, 1, ConvertToNothing, NULL,NULL,"allargs",NULL,NULL,NULL,NULL,NULL}} }, Index: generic/nsfAPI.nxdocindex =================================================================== diff -u -rc03f5a73e6aba594682fe6dbae0621b37bb2599d -r8040970d348ab537d9e3fefbc7f15d262ca52870 --- generic/nsfAPI.nxdocindex (.../nsfAPI.nxdocindex) (revision c03f5a73e6aba594682fe6dbae0621b37bb2599d) +++ generic/nsfAPI.nxdocindex (.../nsfAPI.nxdocindex) (revision 8040970d348ab537d9e3fefbc7f15d262ca52870) @@ -5,6 +5,7 @@ set ::nxdoc::include(::nsf::__profile_clear) 0 set ::nxdoc::include(::nsf::__profile_get) 0 set ::nxdoc::include(::nsf::__unset_unknown_args) 0 +set ::nxdoc::include(::nsf::asm::proc) 0 set ::nxdoc::include(::nsf::configure) 1 set ::nxdoc::include(::nsf::colon) 0 set ::nxdoc::include(::nsf::directdispatch) 0 @@ -16,6 +17,7 @@ set ::nxdoc::include(::nsf::method::alias) 1 set ::nxdoc::include(::nsf::method::assertion) 1 set ::nxdoc::include(::nsf::method::create) 1 +set ::nxdoc::include(::nsf::method::asmcreate) 0 set ::nxdoc::include(::nsf::method::delete) 1 set ::nxdoc::include(::nsf::method::forward) 1 set ::nxdoc::include(::nsf::method::property) 1 Index: generic/nsfAssemble.c =================================================================== diff -u --- generic/nsfAssemble.c (revision 0) +++ generic/nsfAssemble.c (revision 8040970d348ab537d9e3fefbc7f15d262ca52870) @@ -0,0 +1,1075 @@ +#define ASM_INFO_DECL 0x0001 +#define ASM_INFO_PAIRS 0x0002 +#define ASM_INFO_SKIP1 0x0004 + +typedef struct AsmInstructionInfo { + int flags; + CONST char **argTypes; + int minArgs; + int maxArgs; + int cArgs; +} AsmInstructionInfo; + +typedef struct AsmInstruction { + Tcl_ObjCmdProc *cmd; + ClientData clientData; + int argc; + Tcl_Obj **argv; +} AsmInstruction; + +typedef struct AsmArgReference { + int argNr; + Tcl_Obj **objPtr; +} AsmArgReference; + +typedef struct AsmCompiledProc { + struct AsmInstruction *ip; /* pointer to the next writable instruction */ + struct AsmInstruction *code; + NsfObject *currentObject; + int status; + int nrLocals; + Tcl_Obj **firstObj; /* pointer to staticObjs */ + Tcl_Obj **locals; /* pointer to staticObjs */ + Tcl_Obj **slots; /* pointer to staticObjs */ + Tcl_Obj *staticObjs[30]; // 30 static objs for the time being TODO overflows/dynamic + int nrAsmArgReferences; + struct AsmArgReference argReferences[10]; // for the time being TODO overflows/dynamic +} AsmCompiledProc; + +typedef struct AsmPatches { + int targetAsmInstruction; + int sourceAsmInstruction; + int argvIndex; +} AsmPatches; + +typedef struct AsmProcClientData { + NsfObject *object; /* common field of TclCmdClientData */ + AsmCompiledProc *asmProc; + NsfParamDefs *paramDefs; + int with_ad; +} AsmProcClientData; + +typedef struct AsmResolverInfo { + Tcl_Command cmd; + NsfObject *object; + AsmCompiledProc *asmProc; +} AsmResolverInfo; + +AsmInstruction *AsmInstructionNew(AsmCompiledProc *proc, Tcl_ObjCmdProc* objProc, int argc) { + proc->ip->cmd = objProc; + proc->ip->argc = argc; + proc->ip->argv = proc->firstObj; + proc->firstObj += argc; + return proc->ip++; +} + +void AsmLocalsAlloc(AsmCompiledProc *proc, int nrLocals) { + proc->nrLocals = nrLocals; + proc->firstObj += nrLocals; +} + +void AsmArgSet(AsmCompiledProc *proc, int argNr, Tcl_Obj **addr) { + AsmArgReference *arPtr = &proc->argReferences[proc->nrAsmArgReferences]; + arPtr->argNr = argNr; + arPtr->objPtr = addr; + proc->nrAsmArgReferences ++; +} + +void AsmInstructionPrint(AsmInstruction *ip) { + int i; + fprintf(stderr, "(%d) ", ip->argc); + for (i=0; iargc; i++) {fprintf(stderr, "%s ", Tcl_GetString(ip->argv[i]));} + fprintf(stderr, "\n"); +} + +static int +AsmExecute(ClientData cd, Tcl_Interp *interp, AsmCompiledProc *proc, int argc, Tcl_Obj *CONST argv[]) { + //AsmInstruction *ip; + int i, result; + +#if 0 + Var *compiledLocals; + + compiledLocals = ((Interp *) interp)->varFramePtr->compiledLocals; + if (compiledLocals) { + fprintf(stderr, "compiledLocals = %p\n", compiledLocals); + } +#endif + + /* + * Place a copy of the actual argument into locals. + */ + for (i=1; i < argc; i++) { + proc->locals[i-1] = argv[i]; + } + /* + * Update all references to compiled arguments. + */ + for (i=0; i < proc->nrAsmArgReferences; i++) { + AsmArgReference *arPtr = &proc->argReferences[i]; + *(arPtr->objPtr) = proc->locals[arPtr->argNr]; + } + + /* + * Set the instruction pointer to the begin of the code. + */ + proc->ip = proc->code; + //fprintf(stderr, "ip %p\n", proc->ip); + + while (*proc->ip->cmd) { + //fprintf(stderr, "will execute instruction ip %p cmd %p %p/%d\n", ip, ip->cmd, ip->argv[0], ip->argc); + //if (ip->cmd == tclFormat) {AsmInstructionPrint(ip);} + //if (ip->cmd == (Tcl_ObjCmdProc*)tclDispatch) {AsmInstructionPrint(ip);} + result = (*proc->ip->cmd)(proc->ip->clientData, interp, proc->ip->argc, proc->ip->argv); + /*fprintf(stderr, "%s returned <%s> (%d)\n", + Tcl_GetString(ip->argv[0]), + Tcl_GetString(Tcl_GetObjResult(interp)), result);*/ + if (unlikely(result != TCL_OK)) break; + proc->ip++; + //fprintf(stderr, "ip %p\n", proc->ip); + } + + return result; +} + + +/* + *---------------------------------------------------------------------- + * asmStoreResult, asmSetResult -- + * + * Define helper instructions for moving around runtime date + * between the arguments. TODO: currently matching DecrRefCount + * from asmStoreResult is missing. + * + *---------------------------------------------------------------------- + */ + +#if defined(USE_OWN_SET) +int asmSet(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + Tcl_Obj *resultObj; + assert(objc == 3); + resultObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2], 0); + Tcl_SetObjResult(interp, resultObj); + fprintf(stderr, "set %s %s => returns <%s>\n", + Tcl_GetString(objv[1]), + Tcl_GetString(objv[2]), + Tcl_GetString(resultObj)); + return TCL_OK; +} +#endif + +int asmStoreResult(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *target[]) { + target[0] = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(target[0]); + return TCL_OK; +} + +int asmSetResult(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + AsmCompiledProc *asmProc = clientData; + int indexValue = PTR2INT(objv[0]); + + Tcl_SetObjResult(interp, asmProc->slots[indexValue]); + //fprintf(stderr, "asmSetResult index %d => '%s'\n", indexValue, ObjStr(asmProc->slots[indexValue])); + return TCL_OK; +} + +int asmNoop(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + return TCL_OK; +} + +int asmDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + //int i; + //fprintf(stderr, "dispatch (%d): \n", objc); + //for (i=0; iobject, interp, objc-1, objv+1, + resInfo->cmd, resInfo->object, NULL, + ObjStr(objv[1]), 0, 0); +} + +int asmMethodSelfDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + AsmResolverInfo *resInfo = clientData; + Tcl_Command cmd = resInfo->cmd ? resInfo->cmd : Tcl_GetCommandFromObj(interp, objv[0]); + + return MethodDispatch(resInfo->asmProc->currentObject, interp, objc, objv, + cmd, resInfo->asmProc->currentObject, NULL, + ObjStr(objv[0]), 0, 0); +} + +int asmMethodSelfCmdDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + AsmResolverInfo *resInfo = clientData; + assert(resInfo->cmd != NULL); + return Tcl_NRCallObjProc(interp, Tcl_Command_objProc(resInfo->cmd), resInfo->asmProc->currentObject, objc, objv); +} + +int asmMethodSelf(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + AsmCompiledProc *asmProc = clientData; + Tcl_SetObjResult(interp, asmProc->currentObject->cmdName); + return TCL_OK; +} + +int asmJump(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + AsmCompiledProc *asmProc = clientData; + int instructionIndex; + + instructionIndex = PTR2INT(objv[0]); + //fprintf(stderr, "asmJump oc %d instructionIndex %d\n", objc, instructionIndex); + asmProc->ip = &asmProc->code[instructionIndex] - 1; + + return TCL_OK; +} + +int asmJumpTrue(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + AsmCompiledProc *asmProc = clientData; + int instructionIndex; + + if (asmProc->status) { + instructionIndex = PTR2INT(objv[0]); + //fprintf(stderr, "asmJump oc %d instructionIndex %d\n", objc, instructionIndex); + asmProc->ip = &asmProc->code[instructionIndex] - 1; + } + + return TCL_OK; +} + +int asmLeScalar(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + AsmCompiledProc *asmProc = clientData; + int valueIndex1, valueIndex2, value1, value2; + //fprintf(stderr, "asmLeScalar oc %d op1 %p op2 %p\n", objc, objv[0], objv[1]); + + valueIndex1 = PTR2INT(objv[0]); + valueIndex2 = PTR2INT(objv[1]); + + //fprintf(stderr, "asmLeScalar oc %d index1 %d index2 %d\n", objc, valueIndex1, valueIndex2); + + // for the time being, we compare two int values + Tcl_GetIntFromObj(interp, asmProc->slots[valueIndex1], &value1); + Tcl_GetIntFromObj(interp, asmProc->slots[valueIndex2], &value2); + //fprintf(stderr, "asmLeScalar oc %d op1 %d op2 %d => %d\n", objc, value1, value2, value1 <= value2); + + asmProc->status = value1 <= value2; + + return TCL_OK; +} + +int asmSetScalar(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + AsmCompiledProc *asmProc = clientData; + int indexValue; + + indexValue = PTR2INT(objv[0]); + //fprintf(stderr, "asmSetScalar oc %d var %d = %s\n", objc, indexValue, ObjStr(objv[1])); + + asmProc->slots[indexValue] = objv[1]; + return TCL_OK; +} + +int asmSetScalarResult(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + AsmCompiledProc *asmProc = clientData; + int indexValue = PTR2INT(objv[0]); + //fprintf(stderr, "asmSetScalar oc %d var %d = %s\n", objc, indexValue, ObjStr(objv[1])); + + asmProc->slots[indexValue] = Tcl_GetObjResult(interp); + return TCL_OK; +} + +int asmIncrScalar(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *objv[]) { + AsmCompiledProc *asmProc = clientData; + int indexValue1, indexValue2, intValue, incrValue; + Tcl_Obj *intObj, *incrObj; + + indexValue1 = PTR2INT(objv[0]); + indexValue2 = PTR2INT(objv[1]); + + //fprintf(stderr, "asmIncrScalar oc %d var[%d] incr var[%d]\n", objc, indexValue1, indexValue2); + + intObj = asmProc->slots[indexValue1]; + incrObj = asmProc->slots[indexValue2]; + + Tcl_GetIntFromObj(interp, intObj, &intValue); + Tcl_GetIntFromObj(interp, incrObj, &incrValue); + + //fprintf(stderr, "asmIncrScalar %d + %d = %d\n", intValue, incrValue, intValue + incrValue); + + Tcl_InvalidateStringRep(intObj); + intObj->internalRep.longValue = (long)(intValue + incrValue); + + Tcl_SetObjResult(interp, intObj); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * tcl5_assemble -- + * + * Compile body from assembly text to a struct AsmCompiledProc + * containing the instructions and data. + * + *---------------------------------------------------------------------- + */ + +enum asmCmdArgIndex {asmCmdArgArgIdx, asmCmdArgIntIdx, asmCmdArgObjIdx, asmCmdArgResultIdx, asmCmdArgVarIdx}; +static CONST char *asmCmdArgTypes[] = {"arg", "int", "obj", "result", "var", NULL}; + +enum asmAddrIndex {asmAddrCodeIdx, asmAddrArgvIdx}; +static CONST char *asmAddrTypes[] = {"code", "argv", NULL}; + +static int +AsmCheckArgTypes(Tcl_Interp *interp, int from, int to, CONST char **argTypes, + int nrObjs, Tcl_Obj **wordOv, Tcl_Obj *lineObj) { + int j, result; + + for (j = from; j < to; j += 2) { + int argIndex, intValue; + //fprintf(stderr, "check arg type %s\n", Tcl_GetString(wordOv[j])); + result = Tcl_GetIndexFromObj(interp, wordOv[j], argTypes, "asm internal arg type", 0, &argIndex); + if (result != TCL_OK) { + return NsfPrintError(interp, + "Asm: instruction argument has unknown type: '%s', line %s\n", + Tcl_GetString(wordOv[j]), Tcl_GetString(lineObj)); + } + //fprintf(stderr, "check arg value %s\n", Tcl_GetString(wordOv[j+1])); + if (Tcl_GetIntFromObj(interp, wordOv[j+1], &intValue) != TCL_OK + || intValue < 0 + || (argTypes == asmCmdArgTypes && argIndex == asmCmdArgObjIdx && intValue > nrObjs)) { + return NsfPrintError(interp, + "Asm: instruction argument of type %s must have numeric index >= 0 (less than max)," + " got '%s', line '%s'", + ObjStr(wordOv[j]), ObjStr(wordOv[j+1]), ObjStr(lineObj)); + } + } + return TCL_OK; +} + +static void +AsmSetArgValue(Tcl_Interp *interp, int from, int to, int currentArg, + AsmInstruction *inst, AsmCompiledProc *asmProc, + Tcl_Obj **wordOv, int verbose) { + int j; + + for (j = from; j < to; j += 2, currentArg++) { + int argIndex, intValue; + + Tcl_GetIndexFromObj(interp, wordOv[j], asmCmdArgTypes, "asm cmd arg type", 0, &argIndex); + Tcl_GetIntFromObj(interp, wordOv[j+1], &intValue); + + if (verbose) { + fprintf(stderr, "AsmSetArgValue (type %d) arg[%d] := %s[%s]\n", + argIndex, currentArg, ObjStr(wordOv[j]), ObjStr(wordOv[j+1])); + } + + switch (argIndex) { + case asmCmdArgObjIdx: + inst->argv[currentArg] = asmProc->slots[intValue]; + break; + + case asmCmdArgArgIdx: + AsmArgSet(asmProc, intValue, &inst->argv[currentArg]); + break; + + case asmCmdArgResultIdx: + inst->argv[currentArg] = NULL; + break; + + case asmCmdArgIntIdx: + inst->argv[currentArg] = INT2PTR(intValue); + break; + + case asmCmdArgVarIdx: + fprintf(stderr, ".... var set [%d] = %s\n", currentArg, ObjStr(wordOv[j+1])); + inst->argv[currentArg] = wordOv[j+1]; + Tcl_IncrRefCount(inst->argv[currentArg]); // TODO: DECR missing + break; + + } + /*fprintf(stderr, "[%d] inst %p name %s arg[%d] %s\n", currentAsmInstruction, + inst, Tcl_GetString(inst->argv[0]), currentArg, + inst->argv[currentArg] ? Tcl_GetString(inst->argv[currentArg]) : "NULL");*/ + } +} + + +static int +AsmAssemble(ClientData cd, Tcl_Interp *interp, Tcl_Obj *nameObj, + int nrArgs, Tcl_Obj *asmObj, AsmCompiledProc **retAsmProc) { + AsmPatches patchArray[100], *patches = &patchArray[0], *patchPtr; // TODO: make me dynamic + Tcl_Command cmd; + AsmCompiledProc *asmProc; + AsmInstruction *inst; + int i, result, nrAsmInstructions, nrObjs, totalArgvArgs; + int oc, currentAsmInstruction, currentSlot; + Tcl_Obj **ov; + CONST char *procName; + + enum asmAsmInstructionIndex { + asmObjIdx, + asmVarIdx, + asmNoopIdx, + asmCmdIdx, + asmEvalIdx, + asmMethodDelegateDispatchIdx, + asmMethodSelfDispatchIdx, + asmSelfIdx, + asmJumpIdx, + asmJumpTrueIdx, + asmLeScalarIdx, + asmSetScalarIdx, + asmSetScalarResultIdx, + asmIncrScalarIdx, + asmResultIdx, + asmStoreIdx + }; + static CONST char *asmInstructionNames[] = { + "obj", + "var", + "noop", + "cmd", + "eval", + "methodDelegateDispatch", + "methodSelfDispatch", + "self", + "jump", + "jumpTrue", + "leScalar", + "setScalar", + "setScalarResult", + "incrScalar", + "result", + "store", + NULL + }; + +#define NR_PAIRS -1 +#define NR_PAIRS1 -2 + + static AsmInstructionInfo asmInstructionInfo[] = { + /* asmObjIdx, */ + {ASM_INFO_DECL, NULL, 2, 2, 0}, + /* asmVarIdx, */ + {ASM_INFO_DECL|ASM_INFO_PAIRS, asmCmdArgTypes, 3, 3, 0}, // should force just "obj" arg1 + /* asmNoopIdx, */ + {0, NULL, 1, 1, 0}, + /* asmCmdIdx, */ + {ASM_INFO_PAIRS|ASM_INFO_SKIP1, NULL, 2, -1, NR_PAIRS1}, + /* asmEvalIdx, */ + {ASM_INFO_PAIRS, asmCmdArgTypes, 3, -1, NR_PAIRS}, + /* asmMethodDelegateDispatchIdx, */ + {ASM_INFO_PAIRS, asmCmdArgTypes, 5, -1, NR_PAIRS}, + /* asmMethodSelfDispatchIdx, */ + {ASM_INFO_PAIRS, asmCmdArgTypes, 3, -1, NR_PAIRS}, + /* asmSelfIdx, */ + {0, NULL, 1, 1, 0}, + /* asmJumpIdx, */ + {ASM_INFO_PAIRS, asmCmdArgTypes, 3, 3, 1}, // should force arg1 "int", label + /* asmJumpTrueIdx, */ + {ASM_INFO_PAIRS, asmCmdArgTypes, 3, 3, 1}, // should force arg1 "int", label + /* asmLeScalarIdx, */ + {ASM_INFO_PAIRS, asmCmdArgTypes, 5, 5, 2}, + /* asmSetScalarIdx, */ + {ASM_INFO_PAIRS, asmCmdArgTypes, 5, 5, 2}, // should force arg1 & arg2 "int" + /* asmSetScalarResultIdx, */ + {ASM_INFO_PAIRS, asmCmdArgTypes, 3, 3, 2}, // should force arg1 "int" + /* asmIncrScalarIdx, */ + {ASM_INFO_PAIRS, asmCmdArgTypes, 5, 5, 2}, // should force arg1 "int" + /* asmResultIdx, */ + {ASM_INFO_PAIRS, asmCmdArgTypes, 3, 3, 1}, // should force arg1 "int" + /* asmStoreIdx */ + {ASM_INFO_PAIRS, asmAddrTypes, 5, 5, 0} + }; + + /* + {obj a} + {var obj 0} + {cmd ::format obj 0 obj 3} + {eval obj 0 obj 1 obj 2} + {store code 4 argv 3} + {methodDelegateDispatch obj 0 obj 1 obj 2} + {methodSelfDispatch obj 0 obj 1} + {self} + {jump int 2} + {jumpTrue int 6} + {leScalar int 5 int 4} + {setScalar int 2 arg 0} + {setScalarResult int 2} + {incrScalar int 2 obj 1} + {store code 4 argv 2} + {result obj 0} + */ + + assert(nameObj); + procName = ObjStr(nameObj); + + if (Tcl_ListObjGetElements(interp, asmObj, &oc, &ov) != TCL_OK) { + return NsfPrintError(interp, "Asm code is not a valid list"); + } + + /* + * First Iteration: check wellformedness, determine sizes + */ + nrAsmInstructions = 0; + nrObjs = 0; + totalArgvArgs = 0; + + for (i = 0; i < oc; i++) { + int index, offset, wordOc; + Tcl_Obj *lineObj = ov[i], **wordOv; + + if (Tcl_ListObjGetElements(interp, lineObj, &wordOc, &wordOv) != TCL_OK) { + return NsfPrintError(interp, + "Asm: line is not a well-formed asm instruction: %s", + ObjStr(lineObj)); + } + + result = Tcl_GetIndexFromObj(interp, wordOv[0], asmInstructionNames, "asm instruction", 0, &index); + if (result != TCL_OK) { + return NsfPrintError(interp, + "Asm: line is not a valid asm instruction: word %s, line %s", + ObjStr(wordOv[0]), ObjStr(lineObj)); + } + + offset = (asmInstructionInfo[index].flags & ASM_INFO_SKIP1) ? 2 : 1; + + if ((asmInstructionInfo[index].flags & ASM_INFO_PAIRS) && (wordOc-offset) % 2 == 1) { + return NsfPrintError(interp, "Asm: argument list of cmd must contain pairs: %s", + ObjStr(lineObj)); + } + + if (asmInstructionInfo[index].minArgs > -1 + && wordOc < asmInstructionInfo[index].minArgs) { + return NsfPrintError(interp, "Asm: statement must contain at least %d words: %s", + asmInstructionInfo[index].minArgs, ObjStr(lineObj)); + } + + if (asmInstructionInfo[index].maxArgs > -1 + && wordOc > asmInstructionInfo[index].maxArgs) { + return NsfPrintError(interp, "Asm: statement must contain at most %d words: %s", + asmInstructionInfo[index].maxArgs, ObjStr(lineObj)); + } + + if (asmInstructionInfo[index].argTypes) { + result = AsmCheckArgTypes(interp, offset, wordOc, asmInstructionInfo[index].argTypes, nrObjs, wordOv, lineObj); + if (unlikely(result != TCL_OK)) {return result;} + } + + if ((asmInstructionInfo[index].flags & ASM_INFO_DECL) == 0) { + int cArgs = asmInstructionInfo[index].cArgs; + if (cArgs == NR_PAIRS) { + cArgs = (wordOc-offset) / 2; + } else if (cArgs == NR_PAIRS1) { + cArgs = 1 + (wordOc-offset) / 2; + } + //fprintf(stderr, "instruction %s need argvargs %d\n", ObjStr(lineObj), cArgs); + totalArgvArgs += cArgs; + + nrAsmInstructions++; + } else { + /* currently obj and var from the same pool, must change... */ + nrObjs ++; + } + + switch (index) { + case asmObjIdx: + case asmVarIdx: + break; + + case asmCmdIdx: + /* {cmd ::set slot 0 slot 2} */ + cmd = Tcl_GetCommandFromObj(interp, wordOv[1]); + if (cmd == NULL) { + return NsfPrintError(interp, + "Asm: cmd is not a valid tcl command: %s\n", + Tcl_GetString( wordOv[1])); + } + break; + + case asmNoopIdx: /* fall through */ + case asmEvalIdx: + case asmMethodDelegateDispatchIdx: + case asmMethodSelfDispatchIdx: + case asmSelfIdx: + case asmJumpIdx: + case asmJumpTrueIdx: + case asmLeScalarIdx: + case asmSetScalarIdx: + case asmSetScalarResultIdx: + case asmIncrScalarIdx: + case asmStoreIdx: + case asmResultIdx: + break; + } + + } + /* END instruction */ + nrAsmInstructions ++; + fprintf(stderr, "%s: nrAsmInstructions %d nrObjs %d nrArgs %d argvArgs %d => data %d\n", + procName, nrAsmInstructions, nrObjs, nrArgs, totalArgvArgs, + nrObjs + nrArgs + totalArgvArgs ); + + /* + * Allocate structures + */ + + asmProc = (AsmCompiledProc *)ckalloc(sizeof(AsmCompiledProc)); + asmProc->code = (AsmInstruction *)ckalloc(sizeof(AsmInstruction) * nrAsmInstructions); + + asmProc->ip = asmProc->code; /* points to the first writable instructon */ + asmProc->firstObj = asmProc->staticObjs; /* point to the first free obj */ + asmProc->locals = asmProc->staticObjs; /* locals is just an alias */ + asmProc->nrLocals = 0; + asmProc->nrAsmArgReferences = 0; + asmProc->slots = asmProc->locals + nrArgs; + //fprintf(stderr, "args = %ld\n", asmProc->slots - asmProc->locals); + + AsmLocalsAlloc(asmProc, nrArgs + nrObjs); + + /* + * Second Iteration: produce code + */ + currentSlot = 0; + currentAsmInstruction = 0; + + for (i = 0; i < oc; i++) { + int index, offset, cArgs, wordOc, codeIndex, argvIndex, j; + Tcl_Obj *lineObj = ov[i], **wordOv; + + Tcl_ListObjGetElements(interp, lineObj, &wordOc, &wordOv); + Tcl_GetIndexFromObj(interp, wordOv[0], asmInstructionNames, "asm instruction", 0, &index); + + offset = (asmInstructionInfo[index].flags & ASM_INFO_SKIP1) ? 2 : 1; + + cArgs = asmInstructionInfo[index].cArgs; + if (cArgs == NR_PAIRS) { + cArgs = (wordOc-offset) / 2; + } else if (cArgs == NR_PAIRS1) { + cArgs = 1 + (wordOc-offset) / 2; + } + + switch (index) { + case asmObjIdx: + /* {obj a} */ + asmProc->slots[currentSlot] = wordOv[1]; + Tcl_IncrRefCount(asmProc->slots[currentSlot]); + currentSlot ++; + /* a line like the following will be needed when freeing this asmProc */ + //for (i=0; i < nrObjs; i++) { Tcl_DecrRefCount(asmProc->slots[i]); } + break; + + case asmVarIdx: + /* {var obj 0} */ + // for now, we just allocate a tcl-obj and ignore the name + asmProc->slots[currentSlot] = NULL; + currentSlot ++; + break; + + case asmNoopIdx: + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc*)asmNoop, 0); + break; + + case asmCmdIdx: + /* {cmd ::set slot 0 slot 2} */ + cmd = Tcl_GetCommandFromObj(interp, wordOv[1]); + inst = AsmInstructionNew(asmProc, ((Command *)cmd)->objProc, cArgs); + inst->clientData = ((Command *)cmd)->objClientData; + /* use the assembly word as cmd name; should be ok when we keep assembly around */ + inst->argv[0] = wordOv[1]; + /*fprintf(stderr, "[%d] %s/%d\n", currentAsmInstruction, Tcl_GetString(wordOv[1]), 1+((wordOc-offset)/2));*/ + + AsmSetArgValue(interp, offset, wordOc, 1, inst, asmProc, wordOv, 0); + break; + + case asmMethodDelegateDispatchIdx: + /* {methodDelegateDispatch obj 0 obj 1 obj 2} */ + { Tcl_Command cmd = NULL; + NsfObject *object = NULL; + AsmResolverInfo *resInfo; + + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc*)asmMethodDelegateDispatch00, cArgs); + AsmSetArgValue(interp, offset, wordOc, 0, inst, asmProc, wordOv, 0); + if (strncmp(ObjStr(inst->argv[1]), "::nsf::methods::", 16) == 0) { + cmd = Tcl_GetCommandFromObj(interp, inst->argv[1]); + fprintf(stderr, "%s: asmMethod cmd '%s' => %p\n", procName, ObjStr(inst->argv[1]), cmd); + } + if (strncmp(ObjStr(inst->argv[0]), "::nx::", 6) == 0) { + GetObjectFromObj(interp, inst->argv[0], &object); + fprintf(stderr, "%s: asmMethod object '%s' => %p\n", procName, ObjStr(inst->argv[0]), object); + } + if (cmd && object) { + // experimental: bind obj and method + resInfo = NEW(AsmResolverInfo); // TODO: LEAK + resInfo->cmd = cmd; + resInfo->object = object; + inst->clientData = resInfo; + inst->cmd = (Tcl_ObjCmdProc*)asmMethodDelegateDispatch11; + } else if (cmd) { + inst->clientData = cmd; + } else { + inst->clientData = NULL; + } + } + break; + + case asmMethodSelfDispatchIdx: + /* {methodSelfDispatch obj 0 obj 1 obj 2} */ + { Tcl_Command cmd = NULL; + AsmResolverInfo *resInfo; + + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc*)asmMethodSelfDispatch, cArgs); + AsmSetArgValue(interp, offset, wordOc, 0, inst, asmProc, wordOv, 0); + if (strncmp(ObjStr(inst->argv[0]), "::nsf::methods::", 16) == 0) { + cmd = Tcl_GetCommandFromObj(interp, inst->argv[0]); + if (cmd) { + fprintf(stderr, "%s: asmMethodSelfCmdDispatch cmd '%s' => %p\n", procName, ObjStr(inst->argv[0]), cmd); + inst->cmd = (Tcl_ObjCmdProc*)asmMethodSelfCmdDispatch; + } + } else { + fprintf(stderr, "%s: asmMethodSelfDispatch cmd '%s'\n", procName, ObjStr(inst->argv[0])); + } + resInfo = NEW(AsmResolverInfo); // TODO: LEAK + resInfo->cmd = cmd; + resInfo->asmProc = asmProc; + inst->clientData = resInfo; + } + break; + + case asmResultIdx: + /* {result int 0} */ + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc*)asmSetResult, 1); + AsmSetArgValue(interp, offset, wordOc, 0, inst, asmProc, wordOv, 0); + inst->clientData = asmProc; + break; + + case asmStoreIdx: + /* {store code 4 argv 1} */ + codeIndex = -1; + argvIndex = -1; + for (j = offset; j < wordOc; j += 2) { + int argIndex, intValue; + Tcl_GetIndexFromObj(interp, wordOv[j], asmAddrTypes, "asm internal arg type", 0, &argIndex); + Tcl_GetIntFromObj(interp, wordOv[j+1], &intValue); + switch (argIndex) { + case asmAddrCodeIdx: codeIndex = intValue; break; + case asmAddrArgvIdx: argvIndex = intValue; break; + } + } + // TODO: CHECK codeIndex, argvIndex (>0, reasonable values) + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc*)asmStoreResult, 0); + //fprintf(stderr, "%p setting instruction %d => %d %d\n", patches, currentAsmInstruction, codeIndex, argvIndex); + patches->targetAsmInstruction = currentAsmInstruction; + patches->sourceAsmInstruction = codeIndex; + patches->argvIndex = argvIndex; + patches++; + break; + + case asmEvalIdx: + /* {eval slot 1 slot 2} */ + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc *)asmDispatch, cArgs); + //fprintf(stderr, "[%d] %s/%d\n", currentAsmInstruction, Tcl_GetString(wordOv[1]), ((wordOc-offset)/2)); + AsmSetArgValue(interp, offset, wordOc, 0, inst, asmProc, wordOv, 0); + break; + + case asmJumpIdx: + /* {jump int 2} */ + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc *)asmJump, cArgs); + AsmSetArgValue(interp, offset, wordOc, 0, inst, asmProc, wordOv, 0); + inst->clientData = asmProc; + break; + + case asmJumpTrueIdx: + /* {jumpTrue int 6 */ + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc *)asmJumpTrue, cArgs); + AsmSetArgValue(interp, offset, wordOc, 0, inst, asmProc, wordOv, 0); + inst->clientData = asmProc; + break; + + case asmLeScalarIdx: + /* {leScalar int 5 int 4} */ + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc *)asmLeScalar, cArgs); + AsmSetArgValue(interp, offset, wordOc, 0, inst, asmProc, wordOv, 1); + inst->clientData = asmProc; + break; + + case asmSetScalarIdx: + /* {setScalar int 2 int 0} */ + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc *)asmSetScalar, cArgs); + AsmSetArgValue(interp, offset, wordOc, 0, inst, asmProc, wordOv, 0); + inst->clientData = asmProc; + break; + + case asmSetScalarResultIdx: + /* {setScalarResult int 2} */ + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc *)asmSetScalarResult, cArgs); + AsmSetArgValue(interp, offset, wordOc, 0, inst, asmProc, wordOv, 0); + inst->clientData = asmProc; + break; + + case asmIncrScalarIdx: + /* {incrScalar int 2 int 0} */ + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc *)asmIncrScalar, cArgs); + AsmSetArgValue(interp, offset, wordOc, 0, inst, asmProc, wordOv, 0); + inst->clientData = asmProc; + break; + + case asmSelfIdx: + /* {self} */ + inst = AsmInstructionNew(asmProc, (Tcl_ObjCmdProc *)asmMethodSelf, 0); + inst->clientData = asmProc; + break; + } + + if ((asmInstructionInfo[index].flags & ASM_INFO_DECL) == 0) { + currentAsmInstruction ++; + } + } + + /* + * add END instruction + */ + inst = AsmInstructionNew(asmProc, NULL, 0); + + /* + * All addresses are determined, apply the argv patches triggered + * from above. + */ + + for (patchPtr = &patchArray[0]; patchPtr < patches; patchPtr++) { + fprintf(stderr, "wanna patch code[%d]->argv = code[%d]->argv[%d]\n", + patchPtr->targetAsmInstruction, patchPtr->sourceAsmInstruction, patchPtr->argvIndex); + /* set the argument vector of code[1] to the address of code[4]->argv[1] */ + (&asmProc->code[patchPtr->targetAsmInstruction])->argv = + &(&asmProc->code[patchPtr->sourceAsmInstruction])->argv[patchPtr->argvIndex]; + } + + *retAsmProc = asmProc; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * NsfAsmProcDeleteProc -- + * + * Tcl_CmdDeleteProc for NsfAsmProcDeleteProc. Is called, whenever a + * NsfAsmProcDeleteProc is deleted and frees the associated client data. + * + * Results: + * None. + * + * Side effects: + * Frees client-data + * + *---------------------------------------------------------------------- + */ +static void +NsfAsmProcDeleteProc(ClientData clientData) { + AsmProcClientData *cd = clientData; + + /*fprintf(stderr, "NsfAsmProcDeleteProc received %p\n", clientData);*/ + + fprintf(stderr, "NsfAsmProcDeleteProc: TODO free asmProc\n"); + if (cd->paramDefs) { + /* tcd->paramDefs is freed by NsfProcDeleteProc() */ + fprintf(stderr, "NsfAsmProcDeleteProc: TODO free paramDefs\n"); + } + FREE(AsmProcClientData, cd); +} + +/* + *---------------------------------------------------------------------- + * NsfAsmProc -- + * + * Tcl_ObjCmdProc implementing Asm procs. This function processes + * the argument list in accordance with the parameter definitions + * and calls in case of success the asm proc body. + * + * Results: + * Tcl return code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +extern int +NsfAsmProc(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + AsmProcClientData *cd = clientData; + int result; + + assert(cd); + assert(cd->asmProc); + //fprintf(stderr, "NsfAsmProcStub %s is called, tcd %p object %p\n", ObjStr(objv[0]), cd, cd->object); + + if (likely(cd->paramDefs && cd->paramDefs->paramsPtr)) { + ParseContext *pcPtr = (ParseContext *) NsfTclStackAlloc(interp, sizeof(ParseContext), "parse context"); + ALLOC_ON_STACK(Tcl_Obj*, objc, tov); + + fprintf(stderr, "not implemented yet\n"); + pcPtr = (ParseContext *)tov; // dummy operation to keep compiler quiet +#if 0 + /* + * We have to substitute the first element of objv with the name + * of the function to be called. Since objv is immutable, we have + * to copy the full argument vector and replace the element on + * position [0] + */ + memcpy(tov, objv, sizeof(Tcl_Obj *)*(objc)); + //tov[0] = tcd->procName; + + /* If the argument parsing is ok, the body will be called */ + result = ProcessMethodArguments(pcPtr, interp, NULL, 0, + cd->paramDefs, objv[0], + objc, tov); + + if (likely(result == TCL_OK)) { + result = InvokeShadowedProc(interp, cd->procName, cd->cmd, pcPtr); + } else { + /*Tcl_Obj *resultObj = Tcl_GetObjResult(interp); + fprintf(stderr, "NsfProcStub: incorrect arguments (%s)\n", ObjStr(resultObj));*/ + ParseContextRelease(pcPtr); + NsfTclStackFree(interp, pcPtr, "release parse context"); + } +#endif + /*fprintf(stderr, "NsfProcStub free on stack %p\n", tov);*/ + FREE_ON_STACK(Tcl_Obj *, tov); + + } else { + int requiredArgs = cd->asmProc->slots - cd->asmProc->locals; + + //fprintf(stderr, "no compiled parameters\n"); + if (unlikely(requiredArgs != objc-1)) { + return NsfPrintError(interp, "wrong # of arguments"); + } + cd->asmProc->currentObject = cd->object; + result = AsmExecute(NULL, interp, cd->asmProc, objc, objv); + + } + + return result; +} + + + + +static int +NsfAsmProcAddParam(Tcl_Interp *interp, NsfParsedParam *parsedParamPtr, + Tcl_Obj *nameObj, Tcl_Obj *bodyObj, int with_ad) { + fprintf(stderr, "NsfAsmProcAddParam not implemented yet\n"); + //CONST char *procName = ObjStr(nameObj); + + return TCL_OK; +} + +static int +NsfAsmProcAddArgs(Tcl_Interp *interp, Tcl_Obj *argumentsObj, + Tcl_Obj *nameObj, Tcl_Obj *bodyObj, int with_ad) { + int argc, result; + Tcl_Obj **argv; + AsmCompiledProc *asmProc; + AsmProcClientData *cd; + Tcl_Command cmd; + CONST char *procName = ObjStr(nameObj); + + if (unlikely(Tcl_ListObjGetElements(interp, argumentsObj, &argc, &argv) != TCL_OK)) { + return NsfPrintError(interp, "argument list invalid '%s'", ObjStr(argumentsObj)); + } + + result = AsmAssemble(NULL, interp, nameObj, argc, bodyObj, &asmProc); + if (unlikely(result != TCL_OK)) { + return result; + } + + cd = NEW(AsmProcClientData); + cd->object = NULL; + cd->asmProc = asmProc; + cd->paramDefs = NULL; + cd->with_ad = with_ad; + + cmd = Tcl_CreateObjCommand(interp, procName, NsfAsmProc, + cd, NsfAsmProcDeleteProc); + return TCL_OK; +} + + +/* +cmd method::asmcreate NsfAsmMethodCreateCmd { + {-argName "object" -required 1 -type object} + {-argName "-inner-namespace" -nrargs 0} + {-argName "-per-object" -nrargs 0} + {-argName "-reg-object" -required 0 -nrargs 1 -type object} + {-argName "name" -required 1 -type tclobj} + {-argName "arguments" -required 1 -type tclobj} + {-argName "body" -required 1 -type tclobj} +} +*/ + +static int +NsfAsmMethodCreateCmd(Tcl_Interp *interp, NsfObject *defObject, + int withInner_namespace, int withPer_object, NsfObject *regObject, + Tcl_Obj *nameObj, Tcl_Obj *argumentsObj, Tcl_Obj *bodyObj) { + int argc, result; + Tcl_Obj **argv; + AsmCompiledProc *asmProc; + AsmProcClientData *cd; + NsfClass *cl = + (withPer_object || ! NsfObjectIsClass(defObject)) ? + NULL : (NsfClass *)defObject; + + // not handled: withInner_namespace, regObject, no pre and post-conditions + + if (cl == 0) { + RequireObjNamespace(interp, defObject); + } + + if (unlikely(Tcl_ListObjGetElements(interp, argumentsObj, &argc, &argv) != TCL_OK)) { + return NsfPrintError(interp, "argument list invalid '%s'", ObjStr(argumentsObj)); + } + + result = AsmAssemble(NULL, interp, nameObj, argc, bodyObj, &asmProc); + if (unlikely(result != TCL_OK)) { + return result; + } + + cd = NEW(AsmProcClientData); + cd->asmProc = asmProc; + cd->paramDefs = NULL; + cd->with_ad = 0; + + if (cl == NULL) { + result = NsfAddObjectMethod(interp, (Nsf_Object *)defObject, ObjStr(nameObj), + (Tcl_ObjCmdProc *)NsfAsmProc, + cd, NsfAsmProcDeleteProc, 0); + } else { + result = NsfAddClassMethod(interp, (Nsf_Class *)cl, ObjStr(nameObj), + (Tcl_ObjCmdProc *)NsfAsmProc, + cd, NsfAsmProcDeleteProc, 0); + } + + return result; +}