Tcl Source Code

Changes On Branch spjuth-macro
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes In Branch spjuth-macro Excluding Merge-Ins

This is equivalent to a diff from a3653be454 to 6c2d43749a

2015-03-02
08:54
Deleted Win95/98-specific documentation as those platforms have long been unsupported. check-in: 792da66b36 user: ashok tags: trunk
2015-03-01
13:24
Merge from trunk check-in: 604b35d43a user: pspjuth tags: spjuth-execpwd
01:37
Merge from trunk Leaf check-in: 6c2d43749a user: pspjuth tags: spjuth-macro
01:34
Merge from trunk check-in: ccd49df5ea user: pspjuth tags: spjuth-macro
2015-02-28
23:48
Merge from trunk check-in: f9f2084a28 user: pspjuth tags: spjuth-parse
23:02
Merge from trunk check-in: 819b089b26 user: pspjuth tags: spjuth-complex
2015-02-26
16:57
Bump to 8.6.4. check-in: 0ae41bd701 user: dgp tags: core-8-6-4-rc
16:35
merge trunk check-in: f28efa3202 user: dgp tags: novem
2015-02-20
20:19
[32b6159246] Accept aspect patch for broken [lreplace] bytecode. No more [lreplace {1 2 3} 2 0] => 1... check-in: a3653be454 user: dgp tags: trunk
19:30
[e08c2c407b] The getHandleProc routine in the Tcl_Channel struct is optional. Update the docs to mak... check-in: 4b4a843052 user: dgp tags: trunk
2015-02-19
06:29
undo erroneous change in [1fa2e32e07] Closed-Leaf check-in: 0a7c347ebc user: aspect tags: aspect-lreplace-fix

Changes to generic/tclBasic.c.

851
852
853
854
855
856
857



858
859
860
861
862
863
864
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867







+
+
+







            "::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 */
8036
8037
8038
8039
8040
8041
8042








































8043
8044
8045
8046
8047
8048
8049
8039
8040
8041
8042
8043
8044
8045
8046
8047
8048
8049
8050
8051
8052
8053
8054
8055
8056
8057
8058
8059
8060
8061
8062
8063
8064
8065
8066
8067
8068
8069
8070
8071
8072
8073
8074
8075
8076
8077
8078
8079
8080
8081
8082
8083
8084
8085
8086
8087
8088
8089
8090
8091
8092







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    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

Changes to generic/tclCompCmds.c.

3467
3468
3469
3470
3471
3472
3473


























































































3474
3475
3476
3477
3478
3479
3480
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







	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

Changes to generic/tclCompile.c.

1422
1423
1424
1425
1426
1427
1428

1429
1430
1431
1432
1433
1434
1435
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436







+







{
    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;

Changes to generic/tclCompile.h.

287
288
289
290
291
292
293


294
295
296
297
298
299
300
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302







+
+







				 * 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

Changes to generic/tclExecute.c.

14
15
16
17
18
19
20








21
22
23
24
25
26
27
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35







+
+
+
+
+
+
+
+







 * 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

857
858
859
860
861
862
863














864
865
866
867
868
869
870














871
872
873
874
875
876
877
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913







+
+
+
+
+
+
+
+
+
+
+
+
+
+







+
+
+
+
+
+
+
+
+
+
+
+
+
+







 *	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
2343
2344
2345
2346
2347
2348
2349
































2350
2351
2352
2353
2354
2355
2356
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







	    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!)

Changes to generic/tclInt.h.

3374
3375
3376
3377
3378
3379
3380



3381
3382
3383
3384
3385
3386
3387
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390







+
+
+







			    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[]);
3594
3595
3596
3597
3598
3599
3600



3601
3602
3603
3604
3605
3606
3607
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613







+
+
+







			    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);

Changes to generic/tclNamesp.c.

4873
4874
4875
4876
4877
4878
4879
4880

4881
4882
4883
4884
4885
4886
4887
4873
4874
4875
4876
4877
4878
4879

4880
4881
4882
4883
4884
4885
4886
4887







-
+








    if (command != NULL) {
	/*
	 * 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++;
	    }
	}

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

Added unix/macro.tcl.































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
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.










































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
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.


















































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
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.






























































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
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.


























































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
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.







































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
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]