Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -853,10 +853,13 @@ cmdPtr->compileProc = &TclCompileAssembleCmd; Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, NRCoroInjectObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "::tcl::RegisterMacro", + Tcl_RegisterMacroObjCmd, NULL, NULL); + #ifdef USE_DTRACE /* * Register the tcl::dtrace command. */ @@ -8038,10 +8041,50 @@ TCL_DTRACE_DEBUG_LOG() #endif /* USE_DTRACE */ +int +Tcl_RegisterMacroObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + char *fullName; + Tcl_Command cmd; + Tcl_Command origCmd; + Command *cmdPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + + fullName = TclGetString(objv[1]); + + cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, fullName, NULL, /*flags*/ 0); + if (cmd == (Tcl_Command) NULL) { + Tcl_AppendResult(interp, "No such command \"", fullName, "\"", NULL); + return TCL_ERROR; + } + cmdPtr = (Command *) cmd; + + origCmd = TclGetOriginalCommand(cmd); + if (origCmd != NULL) { + cmdPtr = (Command *) origCmd; + } + + if (cmdPtr->compileProc != NULL && cmdPtr->compileProc != TclCompileMacro) { + Tcl_AppendResult(interp, "Cannot make macro out of compiled command \"", fullName, "\"", NULL); + return TCL_ERROR; + } + cmdPtr->compileProc = TclCompileMacro; + + return TCL_OK; +} /* *---------------------------------------------------------------------- * * Tcl_NRCallObjProc -- * Index: generic/tclCompCmds.c ================================================================== --- generic/tclCompCmds.c +++ generic/tclCompCmds.c @@ -3469,10 +3469,100 @@ if (allocedTokens) { TclStackFree(interp, elemTokenPtr); } *localIndexPtr = localIndex; *isScalarPtr = (elName == NULL); + return TCL_OK; +} + +int +TclCompileMacro( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Command *origCmdPtr; + char *procName, *nsName, *script; + Tcl_Obj *fullNamePtr, *cmd, *scriptPtr;; + Tcl_Obj **elems; + int result, i, numWords; + Tcl_Token *valueTokenPtr; + Tcl_HashEntry *namePtr; + + /* + * Trace through imports to original. + */ + + origCmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + if (origCmdPtr != NULL) { + cmdPtr = origCmdPtr; + } + + /* + * Build fully qualified name of called command. + */ + + namePtr = cmdPtr->hPtr; + procName = Tcl_GetHashKey(namePtr->tablePtr, namePtr); + nsName = cmdPtr->nsPtr->fullName; + + fullNamePtr = Tcl_NewStringObj(nsName, -1); + Tcl_IncrRefCount(fullNamePtr); + if (strcmp(nsName, "::") != 0) { + Tcl_AppendToObj(fullNamePtr, "::", -1); + } + Tcl_AppendToObj(fullNamePtr, procName, -1); + + /* + * Execute macro command to get the substitution script. + */ + + elems = (Tcl_Obj **) ckalloc((parsePtr->numWords + 1) * sizeof(Tcl_Obj *)); + + elems[0] = Tcl_NewStringObj("::tcl::macros", -1); + Tcl_AppendObjToObj(elems[0], fullNamePtr); + elems[1] = fullNamePtr; + + numWords = parsePtr->numWords + 1; + + valueTokenPtr = TokenAfter(parsePtr->tokenPtr); + for (i = 2; i < numWords; i++) { + elems[i] = Tcl_NewStringObj(valueTokenPtr->start, valueTokenPtr->size); + valueTokenPtr = TokenAfter(valueTokenPtr); + } + cmd = Tcl_NewListObj(parsePtr->numWords + 1, elems); + Tcl_IncrRefCount(cmd); + ckfree((char *) elems); + Tcl_DecrRefCount(fullNamePtr); + + result = TclEvalObjEx(interp, cmd, TCL_EVAL_DIRECT, NULL, 0); + Tcl_DecrRefCount(cmd); + if (result != TCL_OK) { + scriptPtr = Tcl_GetObjResult(interp); + printf("Error in Eval\n"); + printf(" %s\n", Tcl_GetString(scriptPtr)); + return TCL_ERROR; + } + + scriptPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(scriptPtr); + + /* + * Compile new command. + */ + + script = Tcl_GetString(scriptPtr); + TclCompileScript(interp, script, -1, envPtr); + + // Keep the object for now to make the script persist. + // MUST BE FIXED + Tcl_DecrRefCount(scriptPtr); + + return TCL_OK; } /* * Local Variables: * mode: c Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -1424,10 +1424,11 @@ assert(tclInstructionTable[LAST_INST_OPCODE+1].name == NULL); envPtr->iPtr = iPtr; envPtr->source = stringPtr; + envPtr->latestCmd = stringPtr; envPtr->numSrcBytes = numBytes; envPtr->procPtr = iPtr->compiledProcPtr; iPtr->compiledProcPtr = NULL; envPtr->numCommands = 0; envPtr->exceptDepth = 0; Index: generic/tclCompile.h ================================================================== --- generic/tclCompile.h +++ generic/tclCompile.h @@ -289,10 +289,12 @@ const char *source; /* The source string being compiled by * SetByteCodeFromAny. This pointer is not * owned by the CompileEnv and must not be * freed or changed by it. */ int numSrcBytes; /* Number of bytes in source. */ + const char *latestCmd; /* Pointer to source of latest command compiled + * in this environment. */ Proc *procPtr; /* If a procedure is being compiled, a pointer * to its Proc structure; otherwise NULL. Used * to compile local variables. Set from * information provided by ObjInterpProc in * tclProc.c. */ Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -16,10 +16,18 @@ */ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" +//#define STATISTICS +#ifdef STATISTICS +#include "statistics.c" +#include +#include +int statLevel = 0; +static int statFlag = 0; +#endif #include "tommath.h" #include #if NRE_ENABLE_ASSERTS #include @@ -859,17 +867,45 @@ * "evalstats" command. It also establishes the link between the Tcl * "tcl_traceExec" and C "tclTraceExec" variables. * *---------------------------------------------------------------------- */ + +#ifdef STATISTICS +static void * TimingLoop(void *unused) +{ + struct timespec ts = {0, 50000}; + + while (1) + { + nanosleep(&ts, NULL); + statFlag = 1; + } + return NULL; +} +#endif static void InitByteCodeExecution( Tcl_Interp *interp) /* Interpreter for which the Tcl variable * "tcl_traceExec" is linked to control * instruction tracing. */ { +#ifdef STATISTICS + { + pthread_t thread; + pthread_attr_t attr; /* pthread_attr_init */ + pthread_attr_init(&attr); + pthread_attr_setschedpolicy(&attr, SCHED_FIFO); + pthread_create(&thread, NULL, TimingLoop, NULL); + pthread_attr_destroy(&attr); + } + if (Tcl_LinkVar(interp, "_statLevel", (char *) &statLevel, + TCL_LINK_INT) != TCL_OK) { + panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); + } +#endif #ifdef TCL_COMPILE_DEBUG if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, TCL_LINK_INT) != TCL_OK) { Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); } @@ -2345,10 +2381,42 @@ goto gotError; } } CACHE_STACK_INFO(); } + + TCL_DTRACE_INST_NEXT(); +#ifdef STATISTICS + if (statFlag) {/* miffo */ + static int init = 0; + static Tcl_WideInt last; + Tcl_Time now; /* Current time */ + Tcl_WideInt usec; + + statFlag = 0; + Tcl_GetTime(&now); + usec = (Tcl_WideInt) now.sec * 1000000 + now.usec; + //usec = (Tcl_WideInt) TclpGetClicks(); + if (init == 0) { + init = 1; + last = usec; + } + if (usec - last >= 100) { + int i = (usec - last) / 100; + last += i * 100; + /* What is current procedure name? */ + if (varFramePtr == NULL || varFramePtr->objc < 1) { + /* Global */ + statistics(interp, "_global", i); + } else { + Tcl_Obj *cmdPtr = varFramePtr->objv[0]; + char *cmd = Tcl_GetString(cmdPtr); + statistics(interp, cmd, i); + } + } + } +#endif /* * These two instructions account for 26% of all instructions (according * to measurements on tclbench by Ben Vitale * [http://www.cs.toronto.edu/syslab/pubs/tcl2005-vitale-zaleski.pdf] Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -3376,10 +3376,13 @@ MODULE_SCOPE int Tcl_ReadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_RegexpObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_RegisterMacroObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_RenameObjCmd(ClientData clientData, @@ -3596,10 +3599,13 @@ MODULE_SCOPE int TclCompileLrangeCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLreplaceCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileMacro(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp, Index: generic/tclNamesp.c ================================================================== --- generic/tclNamesp.c +++ generic/tclNamesp.c @@ -4875,11 +4875,11 @@ /* * Compute the line number where the error occurred. */ iPtr->errorLine = 1; - for (p = script; p != command; p++) { + for (p = script; p != command && *p != 0; p++) { if (*p == '\n') { iPtr->errorLine++; } } ADDED unix/macro.tcl Index: unix/macro.tcl ================================================================== --- /dev/null +++ unix/macro.tcl @@ -0,0 +1,62 @@ +interp alias {} dis {} tcl::unsupported::disassemble +namespace eval tcl::macros {} + +# The call +# tcl::RegisterMacro procname +# sets up a compiler for the procedure which expects ::tcl::macros::procname +# to be present. +# ::tcl::macros::procname will be called with the unsubstituted words +# as arguments and should return a script that should replace the macro. + +# defmacro does all the work for setting up a macro + +proc defmacro {names arglist body} { + foreach name $names { + # Dummy definition of proc, to get full namespace resolution + set procarglist [lrange $arglist 1 end] + proc $name $procarglist [string map [list %name% $name] { + puts "Noncompiled %name%" + }] + # Get fully qualified names + set name [namespace which $name] + set full ::tcl::macros$name + + # Create macro proc + namespace eval [namespace qualifier $full] {} + proc $full $arglist $body + + # Create non-compiled proc that gets called if the call is not + # compiled for whatever reason + set map [list %name% [list $name] %full% [list $full] \ + %args% [list $procarglist]] + proc $name $procarglist [string map $map { + # Body for Macro %name% + set name %name% + set full %full% + set arglist %args% + set cmd [list $full $name] + foreach arg $arglist { + if {$arg eq "args"} { + foreach val $args { + lappend cmd [list $val] + } + } else { + lappend cmd [list [set [lindex $arg 0]]] + } + } + set script [{*}$cmd] + set code [catch {uplevel 1 $script} result] + if {$code} { + set code $::errorCode + } + #puts "Noncompiled $name with '$arglist'" + #puts " Eval '$cmd'" + #puts " Script '$script'" + #puts " Result '$result'" + return -code $code $result + }] + + + tcl::RegisterMacro $name + } +} ADDED unix/macrotest.tcl Index: unix/macrotest.tcl ================================================================== --- /dev/null +++ unix/macrotest.tcl @@ -0,0 +1,41 @@ +package require tcltest +namespace import tcltest::* + +source macro.tcl + +defmacro macrotest {cmd x y} { + if {[lindex [info level 1] 0] eq "::tcl::macros$cmd"} { + set ::macrotestcomp 1 + } else { + set ::macrotestcomp 0 + } + return "expr $x + $y" +} + +test macro-1.1 {simple macro} -body { + set res {} + set a 1 + if 1 { + # bytecompiled previously + set ::macrotestcomp -1 + lappend res [macrotest 4 5] + lappend res $::macrotestcomp + + # bytecompiled previously + set ::macrotestcomp -1 + lappend res [macrotest 5 6] + lappend res $::macrotestcomp + + # not bytecompiled + set ::macrotestcomp -1 + lappend res [[join "macro test" ""] 6 7] + lappend res $::macrotestcomp + + # bytecompiled on the fly + set ::macrotestcomp -1 + lappend res [if $a {macrotest 10 11}] + lappend res $::macrotestcomp + } + set res +} -result {9 -1 11 -1 13 0 21 1} + ADDED unix/test.tcl Index: unix/test.tcl ================================================================== --- /dev/null +++ unix/test.tcl @@ -0,0 +1,49 @@ +source macro.tcl + +defmacro MyMacro {cmd args} { + return [list puts "Hello from compiled MyMacro '$args'"] +} +defmacro MyMacro2 {cmd args} { + return "list [join $args " "]" +} + +defmacro sete {cmd var exp} { + return "set $var \[expr $exp\]" +} + +#proc MyMacro {args} { +# puts "Hello from noncompiled MyMacro" +# return 10 +#} + +#proc MyMacro2 {args} { +# puts "Hello from noncompiled MyMacro2" +#} + +#proc sete {var exp} { +# puts "uncompiled sete" +#} + +#tcl::RegisterMacro MyMacro +#tcl::RegisterMacro MyMacro2 +#tcl::RegisterMacro sete + +namespace export MyMacro +namespace eval apa { namespace import -force ::MyMacro } + +proc hej {{comp 0}} { + if {$comp} return + + MyMacro $comp [list] z + MyMacro2 $comp [list] z + + apa::MyMacro x apa + + set x [expr {$comp + 1}] + sete x {$comp + 1} +} + +puts "*** Compiling body ***" +puts [dis proc hej] +puts "\n*** Execute body ***" +hej ADDED unix/test2.tcl Index: unix/test2.tcl ================================================================== --- /dev/null +++ unix/test2.tcl @@ -0,0 +1,93 @@ +source macro.tcl + +defmacro clear {cmd var} { + return "set $var {}" +} + +defmacro first {cmd list} { + return "lindex $list 0" +} + +defmacro K {cmd x y} { + return "first \[list $x $y\]" +} + +defmacro yank {cmd var} { + return "K \[set $var\] \[set $var {}\]" +} + +defmacro lremove {cmd var index} { + # Danger: index is doubled + return "set $var \[lreplace \[yank $var\] $index $index\]" +} +defmacro lremove2 {cmd var index} { + return "set __tmp__ $index ; set $var \[lreplace \[yank $var\] \$__tmp__ \$__tmp__\]" +} + +defmacro {* + - /} {cmd args} { + set cmd [namespace tail $cmd] + return "expr [list [join $args " $cmd "]]" +} + +defmacro = {cmd args} { + if {[llength $args] != 3} { + return -code error Hubba + } + set exp "" + foreach arg $args { + if {[string match "\$*" $arg]} { + append exp " \"$arg\" " + } elseif {[string length $arg] == 1} { + append exp " $arg " + } else { + return -code error Hubba + } + } + return "expr [list $exp]" +} + +defmacro sete {cmd var exp} { + return "set $var \[expr $exp\]" +} + +defmacro do {cmd body until exp} { + if {$until ne "until"} { + return -code error Hubba + } + set first [string index $body 0] + if {$first ne "\{"} { + return -code error Hobba + } + set last [string index $body end] + set body [string range $body 0 end-1] + append body \n\n "if $exp break\n" $last + return "while 1 $body" +} + +proc foobar {} { + set x 0 ; set y 0; set a 0 ; set b 0 ; set c 0; set d 0; set e 0; set i 0 + set ll {1 2 3 4} ; set "_y x_" 0 + set x 10 + clear x + first $x + K $x $y + K "x y" "y z" + yank x + yank "_y x_" + + set ll [lreplace [yank ll] 3 3] + lremove ll $i + lremove2 ll $i + set sum [+ $a $b [- $c $d] [llength $e]] + sete sum {$a + $b + ($c - $d) + [llength $e]} + set x 0 + do { + incr x + } until {$x > 5} + set a [= $b + $c] +} + +puts "*** Compiling body ***" +puts [dis proc foobar] +puts "\n*** Execute body ***" +foobar ADDED unix/test3.tcl Index: unix/test3.tcl ================================================================== --- /dev/null +++ unix/test3.tcl @@ -0,0 +1,57 @@ +source macro.tcl + +#Ferrieux' funnysyntax from "How to avoid nesting?" c.l.t thread +proc funnysyntax args { + upvar _stack _stack + set _stack {} + foreach a $args { + switch -glob $a { + -> {lappend _stack $_val} + *\ * {regsub -all {<-} $a {[pop _stack]} a;set _val [uplevel 1 $a]} + * {uplevel 1 "set $a \[pop _stack\]"} + } + } + +} + +proc pop vv { + upvar $vv v + set ret [lindex $v end] + set v [lrange $v 0 end-1] + return $ret + +} + +defmacro funnysyntax2 {cmd args} { + set _stack {} + foreach a $args { + # FIXA: Check for non-constant args. Only literals and braced are ok here. + switch -glob $a { + -> {lappend _stack $_val} + *\ * { + regsub -all {<-} $a \[[pop _stack]\] a + # This assumes braced arguments + set _val [lindex $a 0] + } + * {lappend _stack "set $a \[[pop _stack]\]"} + } + } + puts '[lindex $_stack 0]' + return [lindex $_stack 0] +} + +proc foobar {} { + set y [set abc [expr {[expr {2+2}] + 3}]] + puts $y + funnysyntax2 {expr {2+2}} -> {set abc [expr {<- + 3}]} -> y + puts $y + set chosenButton [lindex [dict get [info frame -1] cmd] 0] + puts $chosenButton + funnysyntax2 {info frame -1} -> {dict get <- cmd} -> {lindex <- 0} -> chosenButton + puts $chosenButton +} + +puts "*** Compiling body ***" +puts [dis proc foobar] +puts "\n*** Execute body ***" +foobar ADDED unix/testhex.tcl Index: unix/testhex.tcl ================================================================== --- /dev/null +++ unix/testhex.tcl @@ -0,0 +1,70 @@ +source macro.tcl + +proc exprhex11 {args} { + return 0x[format %llx [uplevel expr $args]] +} +proc exprhex12 {args} { + return 0x[format %llx [uplevel 1 expr $args]] +} +proc exprhex13 {args} { + return 0x[format %llx [uplevel [linsert $args 0 expr]]] +} + +proc exprhex21 {exp} { + return 0x[format %llx [uplevel 1 [list expr $exp]]] +} +proc exprhex22 {exp} { + return [format 0x%llx [uplevel 1 [list expr $exp]]] +} +proc exprhex23 {exp} { + return [format %#llx [uplevel 1 [list expr $exp]]] +} +defmacro exprhex91 {cmd exp} { + return "format 0x%llx \[expr $exp\]" +} +proc exprhex96 {exp} { + return 0xe +} +proc exprhex97 {exp} { + return 0xe +} +proc exprhex98 {exp} { + return 0xe +} +proc exprhex99 {exp} { + return 0xe +} + +proc wrap98 {x y} { + expr {$x + $y} +} +proc wrap96 {x y} { + return 0xe +} +proc wrap97 {x y} { + format 0x%llx [expr {$x + $y}] +} + +set x 5 +set y 9 +set res {} +foreach t [info procs exprhex*] { + regexp {exprhex(.*)} $t -> suffix + if {[info proc wrap$suffix] eq ""} { + proc wrap$suffix {x y} " + $t {\$x + \$y} + " + } + lappend res [wrap$suffix $x $y] +} +set res [lsort -unique $res] +puts $res +wrap91 5 5 +wrap97 5 5 + +foreach t [lsort -dict -decr [info procs exprhex*]] { + regexp {exprhex(.*)} $t -> suffix + puts "$t [time "wrap$suffix \$x \$y" 10000]" +} +#puts [dis proc wrap91] +#puts [dis proc wrap97]