From b339aafb5a533c2d3a07418caba710f1b23f1c41 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Tue, 21 Feb 2017 01:35:15 +0000 Subject: Add [::tcl::unsupported::parseexpr] to display expr parse trees prettily --- generic/tclBasic.c | 3 + generic/tclCompExpr.c | 279 ++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 + 3 files changed, 285 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 6ff5faa..f0faec6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -836,6 +836,9 @@ Tcl_CreateInterp(void) Tcl_DisassembleObjCmd, INT2PTR(1), NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "::tcl::unsupported::parseexpr", + Tcl_ParseAndDumpExprObjCmd, NULL, NULL); + /* Adding the bytecode assembler command */ cmdPtr = (Command *) Tcl_NRCreateCommand(interp, diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index cf93ba9..d5cb11a 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1481,6 +1481,285 @@ ParseExpr( return TCL_ERROR; } + + +/* + * Tree Dump Utilities + */ + +static int +MeasureTree( + OpNode *nodes, + int index) +{ + switch(nodes[index].lexeme&NODE_TYPE) { + case UNARY: + return 1+((nodes[index].right>=0)?MeasureTree(nodes,nodes[index].right):0); + case BINARY: + return 1+((nodes[index].left>=0)?MeasureTree(nodes,nodes[index].left):0) + +((nodes[index].right>=0)?MeasureTree(nodes,nodes[index].right):0); + } + return 1; +} + +struct OpExtra { + void *leftThing; + void *rightThing; + void *middleThing; +}; + +static void +AdornTreeRec(OpNode *nodes,int index,struct OpExtra *extra,Tcl_Obj ***litObjvPtr,Tcl_Obj ***funcObjvPtr,Tcl_Token **tokensPtr) +{ + int ty,x; + + ty=nodes[index].lexeme; + switch(ty&NODE_TYPE) { + case BINARY: + x=nodes[index].left; + if (x>=0) { + AdornTreeRec(nodes,x,extra,litObjvPtr,funcObjvPtr,tokensPtr); + } else { + switch(x) { + case OT_LITERAL: + extra[index].leftThing=(void *)**litObjvPtr; + (*litObjvPtr)++; + break; + case OT_TOKENS: + extra[index].leftThing=(void *)*tokensPtr; + (*tokensPtr)+=(*tokensPtr)->numComponents+1; + break; + } + } + } + if (ty==FUNCTION) { + extra[index].middleThing=(void *)**funcObjvPtr; + (*funcObjvPtr)++; + } + switch(ty&NODE_TYPE) { + case UNARY: + case BINARY: + x=nodes[index].right; + if (x>=0) { + AdornTreeRec(nodes,x,extra,litObjvPtr,funcObjvPtr,tokensPtr); + } else { + switch(x) { + case OT_LITERAL: + extra[index].rightThing=(void *)**litObjvPtr; + (*litObjvPtr)++; + break; + case OT_TOKENS: + extra[index].rightThing=(void *)*tokensPtr; + (*tokensPtr)+=(*tokensPtr)->numComponents+1; + break; + } + } + } +} + +static struct OpExtra * +AdornTree(OpNode *nodes,Tcl_Obj **litObjv,Tcl_Obj **funcObjv,Tcl_Token *tokens) +{ + int n; + struct OpExtra *extra; + + n=MeasureTree(nodes,0); + extra=(struct OpExtra *)ckalloc(n*sizeof(struct OpExtra)); + AdornTreeRec(nodes,0,extra,&litObjv,&funcObjv,&tokens); + + return extra; +} + +static void DecodeNonOps(int x,void *thing,char *dst) +{ + switch(x) { + case OT_EMPTY: + strcpy(dst,"()"); + return; + case OT_TOKENS: + { + int n; + #define MAXTOKS 1023 + char toks[MAXTOKS+1]; + + n=((Tcl_Token *)thing)->size; + if (n>=MAXTOKS) n=MAXTOKS; + memcpy(toks,((Tcl_Token *)thing)->start,n); + toks[n]=0; + sprintf(dst,"TOKENS: %s",toks); + } + return; + case OT_LITERAL: + sprintf(dst,"LITERAL: %s",TclGetString((Tcl_Obj *)thing)); + return; + default: + strcpy(dst,"N/A"); + return; + } +} + +static void +DumpExprTreeIndent( + OpNode *nodes, + int index, + const char *indent, + struct OpExtra *extra) +{ + #define INDENTMAX 1024 + char indent2[INDENTMAX]; + int ty; + static const char *types[]={"AMBIG","BINARY","UNARY","LEAF"}; + static const char *lexemes[256]; + static const struct {int pos;const char *lex;} lexdesc[]={ + {1,"+"},{2,"-"},{3,"bareword"},{4,"incompatible"},{5,"invalid"}, + {0xc1,"number"},{0xc2,"[command]"},{0xc3,"boolean"},{0xc4,"{string}"},{0xc5,"$var"},{0xc6,"\"string\""},{0xc7,"()"}, + {0x81,"+"},{0x82,"-"},{0x83,"function"},{0x84,"start"},{0x85,"("},{0x86,"!"},{0x87,"~"}, + {0x41,"+"},{0x42,"-"},{0x43,","},{0x4c,"?"},{0x4d,":"}, + {0x5B,")"},{0x5c,"end"},{0x5d,";"},{0x5e,":="} + }; + static int lexdone=0; + + if (!lexdone) { + int i; + + lexdone=1; + for(i=0;i<256;i++) lexemes[i]="???"; + for(i=0;i<(int)(sizeof(lexdesc)/sizeof(lexdesc[0]));i++) { + lexemes[lexdesc[i].pos]=lexdesc[i].lex; + } + } + + ty=nodes[index].lexeme; + fprintf(stderr,"--%s(%02X): %s %s\n",types[(ty&NODE_TYPE)>>6],ty,lexemes[ty],(ty==FUNCTION)?TclGetString((Tcl_Obj *)extra[index].middleThing):""); + switch(ty&NODE_TYPE) { + case UNARY: + fprintf(stderr,"%s |\n%s `",indent,indent); + snprintf(indent2,INDENTMAX,"%s ",indent); + if (nodes[index].right<0) { + char buf[1024]; + DecodeNonOps(nodes[index].right,extra[index].rightThing,buf); + fprintf(stderr,"--%s\n",buf); + } else { + DumpExprTreeIndent(nodes,nodes[index].right,indent2,extra); + } + break; + case BINARY: + fprintf(stderr,"%s |\n%s |",indent,indent); + snprintf(indent2,INDENTMAX,"%s |",indent); + if (nodes[index].left<0) { + char buf[1024]; + DecodeNonOps(nodes[index].left,extra[index].leftThing,buf); + fprintf(stderr,"--%s\n",buf); + } else { + DumpExprTreeIndent(nodes,nodes[index].left,indent2,extra); + } + fprintf(stderr,"%s |\n%s `",indent,indent); + snprintf(indent2,INDENTMAX,"%s ",indent); + if (nodes[index].right<0) { + char buf[1024]; + DecodeNonOps(nodes[index].right,extra[index].rightThing,buf); + fprintf(stderr,"--%s\n",buf); + } else { + DumpExprTreeIndent(nodes,nodes[index].right,indent2,extra); + } + break; + } +} + +static void +DumpExprTree( + OpNode *nodes, + int index, + const char *script, + int len, + Tcl_Obj **litObjv, + Tcl_Obj **funcObjv, + Tcl_Token *tokens) +{ + #define MAXSCR 1024 + char scr[MAXSCR]; + struct OpExtra *extra; + + if (len>=(MAXSCR-1)) len=MAXSCR-1; + memcpy(scr,script,len); + scr[len]=0; + fprintf(stderr,"=== EXPR TREE FOR {%s} ===\n\n",scr); + extra=AdornTree(nodes,litObjv,funcObjv,tokens); + DumpExprTreeIndent(nodes,index,"",extra); + fprintf(stderr,"\n=================\n"); + ckfree(extra); +} + +/* + *---------------------------------------------------------------------- + * + * ParseAndDumpExpr, Tcl_ParseAndDumpExprObjCmd -- + * + * These procedures parse a string containing a Tcl expression and + * dump the resulting parse tree to stderr in a readable layout. + * + * Results: + * A standard Tcl return code and result left in interp. + * + * Side effects: + * Output to stderr + * + *---------------------------------------------------------------------- + */ + +static int +ParseAndDumpExpr( + Tcl_Interp *interp, /* Used for error reporting. */ + const char *script, /* The source script to compile. */ + int numBytes) /* Number of bytes in script. */ +{ + OpNode *opTree = NULL; /* Will point to the tree of operators */ + Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ + Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/ + Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + /* Holds the Tcl_Tokens of substitutions */ + + int code = ParseExpr(interp, script, numBytes, &opTree, litList, + funcList, parsePtr, 0 /* parseOnly */); + + if (code == TCL_OK) { + /* + * Valid parse; dump the tree. + */ + + int objc; + Tcl_Obj **litObjv; + Tcl_Obj **funcObjv; + + TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv); + TclListObjGetElements(NULL, funcList, &objc, &funcObjv); + DumpExprTree(opTree,0,script,numBytes,litObjv,funcObjv,parsePtr->tokenPtr); + } + + Tcl_FreeParse(parsePtr); + TclStackFree(interp, parsePtr); + Tcl_DecrRefCount(funcList); + Tcl_DecrRefCount(litList); + ckfree(opTree); + + return code; +} + +int Tcl_ParseAndDumpExprObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]) +{ + char *s; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "expression"); + return TCL_ERROR; + } + s=TclGetString(objv[1]); + + return ParseAndDumpExpr(interp,s,strlen(s)); +} + /* *---------------------------------------------------------------------- diff --git a/generic/tclInt.h b/generic/tclInt.h index f078d18..4b4f1f3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3269,6 +3269,9 @@ MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_ParseAndDumpExprObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); /* Assemble command function */ MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData, -- cgit v0.12