Tcl Source Code

            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
            TclNRAssembleObjCmd, NULL, NULL);
    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.
     */

    Tcl_CreateObjCommand(interp, "::tcl::dtrace", DTraceObjCmd, NULL, NULL);
#endif /* USE_DTRACE */

    return result;
}

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 --
 *
 *	This function calls an objProc directly while managing things properly
 *	if it happens to be an NR objProc. It is meant to be used by extenders

	varTokenPtr[removedParen].size++;
    }
    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
 * c-basic-offset: 4
 * fill-column: 78

{
    Interp *iPtr = (Interp *) interp;

    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;
    envPtr->maxExceptDepth = 0;
    envPtr->maxStackDepth = 0;

				 * are specific to an interpreter so the code
				 * emitted will depend on the interpreter. */
    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. */
    int numCommands;		/* Number of commands compiled. */
    int exceptDepth;		/* Current exception range nesting level; -1

 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"
//#define STATISTICS
#ifdef STATISTICS
#include "statistics.c"
#include <pthread.h>
#include <time.h>
int statLevel = 0;
static int statFlag = 0;
#endif
#include "tommath.h"
#include <math.h>

#if NRE_ENABLE_ASSERTS
#include <assert.h>
#endif

 *	compiling with the TCL_COMPILE_STATS flag, it initializes the array
 *	that counts the executions of each instruction and it creates the
 *	"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");
    }
#endif
#ifdef TCL_COMPILE_STATS

	    if (Tcl_LimitCheck(interp) == TCL_ERROR) {
		CACHE_STACK_INFO();
		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]
     * Resolving them before the switch reduces the cost of branch
     * mispredictions, seems to improve runtime by 5% to 15%, and (amazingly!)

			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
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,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);

			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);
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,
			    Tcl_Parse *parsePtr, Command *cmdPtr,
			    struct CompileEnv *envPtr);

    if (command != NULL) {
	/*
	 * Compute the line number where the error occurred.
	 */

	iPtr->errorLine = 1;
        for (p = script; p != command && *p != 0; p++) {
	    if (*p == '\n') {
		iPtr->errorLine++;
	    }
	}

	if (length < 0) {
	    length = strlen(command);

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
    }
}

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}

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

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

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

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]