diff options
| -rw-r--r-- | doc/jim_tcl.txt | 154 | ||||
| -rw-r--r-- | jim.c | 185 | ||||
| -rw-r--r-- | jim.h | 12 | ||||
| -rw-r--r-- | tests/proc-new.test | 79 | ||||
| -rw-r--r-- | tests/proc.test | 11 | ||||
| -rw-r--r-- | tests/testing.tcl | 13 |
6 files changed, 308 insertions, 146 deletions
diff --git a/doc/jim_tcl.txt b/doc/jim_tcl.txt index 7ac6e3f..8212779 100644 --- a/doc/jim_tcl.txt +++ b/doc/jim_tcl.txt @@ -74,6 +74,7 @@ Since v0.61: 12. Add 'info nameofexecutable' and 'info returncodes' 13. Allow 'catch' to determine what return codes are caught 14. Allow 'incr' to increment an unset variable by first setting to 0 +15. Allow 'args' and optional arguments to the left or required arguments in 'proc' TCL INTRODUCTION ----------------- @@ -953,7 +954,96 @@ procedures. A Tcl procedure can be invoked just like any other Tcl command (it has a name and it receives one or more arguments). The only difference is that its body isn't a piece of C code linked into the program; it is a string containing one or more other -Tcl commands. See the 'proc' command for information on +Tcl commands. + +The 'proc' command is used to create a new Tcl command procedure: + + +*proc* 'name args ?statics? body'+ + +The new command is name *name*, and it replaces any existing command +there may have been by that name. Whenever the new command is +invoked, the contents of *body* will be executed by the Tcl +interpreter. + +*args* specifies the formal arguments to the procedure. +It consists of a list, possibly empty, of the following +argument specifiers: + ++name+:: + Required Argument - A simple argument name. + ++name default+:: + Optional Argument - A two-element list consisting of the + argument name, followed by the default value, which will + be used if the corresponding argument is not supplied. + ++*args*+:: + Variable Argument - The special name 'args', which is + assigned all remaining arguments (including none). The + variable argument may only be specified once. + +Arguments must be provided in the following order, any of which +may be omitted: + +1. Required Arguments (Left) +2. Optional Arguments +3. Variable Argument +4. Required Arguments (Right) + +When the command is invoked, a local variable will be created for each of +the formal arguments to the procedure; its value will be the value +of corresponding argument in the invoking command or the argument's +default value. + +Arguments with default values need not be specified in a procedure +invocation. However, there must be enough actual arguments for all +required arguments, and there must not be any extra actual arguments +(unless the Variable Argument is specified). + +Actual arguments are assigned to formal arguments as follows: +1. Left Required Arguments are assigned from the left +2. Right Required Arguments are assigned from the right +3. Default Arguments are assigned from the left, following the Left Required Arguments. +4. A list is formed from any remaining arguments, which are then + are assigned to the 'args' Variable Argument (if specified). The list will be empty + if there are no remaining arguments. + +When *body* is being executed, variable names normally refer to local +variables, which are created automatically when referenced and deleted +when the procedure returns. One local variable is automatically created +for each of the procedure's arguments. Global variables can be +accessed by invoking the 'global' command or via the '::' prefix. + +*New in Jim* + +In addition to procedure arguments, Jim procedures may declare static variables. +These variables scoped to the procedure and initialised at procedure definition. +Either from the static variable definition, or from the enclosing scope. + +Consider the following example: + + set a 1 + proc a {} {a {b 2}} { + set c 1 + puts "$a $b $c" + incr a + incr b + incr c + } + . a + 1 2 1 + . a + 2 3 1 + +The static variable *a* has no initialiser, so it is initialised from +the enclosing scope with the value 1. (Note that it is an error if there +is no variable with the same name in the enclosing scope). However *b* +has an initialiser, so it is initialised to 2. + +Unlike a local variable, the value of a static variable is retained across +invocations of the procedure. + +See the 'proc' command for information on how to define procedures and what happens when they are invoked. VARIABLES - SCALARS AND ARRAYS @@ -2565,36 +2655,13 @@ proc ~~~~ +*proc* 'name args ?statics? body'+ -The 'proc' command creates a new Tcl command procedure, *name*, replacing -any existing command there may have been by that name. Whenever the -new command is invoked, the contents of *body* will be executed by the +The 'proc' command creates a new Tcl command procedure, *name*. +When the new command is invoked, the contents of *body* will be executed. Tcl interpreter. *args* specifies the formal arguments to the procedure. -It consists of a list, possibly empty, each of whose elements specifies -one argument. Each argument specifier is also a list with either one or -two fields. If there is only a single field in the specifier, then it is -the name of the argument; if there are two fields, then the first is the -argument name and the second is its default value. braces and backslashes -may be used in the usual way to specify complex default values. - -When *name* is invoked, a local variable will be created for each of -the formal arguments to the procedure; its value will be the value -of corresponding argument in the invoking command or the argument's -default value. Arguments with default values need not be specified in -a procedure invocation. However, there must be enough actual arguments -for all the formal arguments that don't have defaults, and there must -not be any extra actual arguments. There is one special case to permit -procedures with variable numbers of arguments. If the last formal -argument has the name 'args', then a call to the procedure may contain -more actual arguments than the procedure has formals. In this case, -all of the actual arguments starting at the one that would be assigned to -'args' are combined into a list (as if the 'list' command had been used); -this combined value is assigned to the local variable 'args'. +If specified, *static*, declares static variables which are bound to the +procedure. -When *body* is being executed, variable names normally refer to local -variables, which are created automatically when referenced and deleted -when the procedure returns. One local variable is automatically created -for each of the procedure's arguments. Global variables can be -accessed by invoking the 'global' command or via the '::' prefix. +See PROCEDURES for detailed information about Tcl procedures. The 'proc' command returns the null string. When a procedure is invoked, the procedure's return value is the value specified in a 'return' command. @@ -2604,35 +2671,6 @@ value is the value of the last command executed in the procedure's body. If an error occurs while executing the procedure body, then the procedure-as-a-whole will return that same error. -*New in Jim* - -In addition to procedure arguments, Jim procedures may declare static variables. -These variables scoped to the procedure and initialised at procedure definition. -Either from the static variable definition, or from the enclosing scope. - -Consider the following example: - - set a 1 - proc a {} {a {b 2}} { - set c 1 - puts "$a $b $c" - incr a - incr b - incr c - } - . a - 1 2 1 - . a - 2 3 1 - -The static variable *a* has no initialiser, so it is initialised from -the enclosing scope with the value 1. (Note that it is an error if there -is no variable with the same name in the enclosing scope). However *b* -has an initialiser, so it is initialised to 2. - -Unlike a local variable, the value of a static variable is retained across -invocations of the procedure. - puts ~~~~ +*puts* ?*-nonewline*? '?fileId? string'+ @@ -3154,7 +3154,7 @@ int Jim_CreateCommand(Jim_Interp *interp, const char *cmdName, int Jim_CreateProcedure(Jim_Interp *interp, const char *cmdName, Jim_Obj *argListObjPtr, Jim_Obj *staticsListObjPtr, Jim_Obj *bodyObjPtr, - int arityMin, int arityMax) + int leftArity, int optionalArgs, int args, int rightArity) { Jim_Cmd *cmdPtr; @@ -3164,8 +3164,10 @@ int Jim_CreateProcedure(Jim_Interp *interp, const char *cmdName, cmdPtr->bodyObjPtr = bodyObjPtr; Jim_IncrRefCount(argListObjPtr); Jim_IncrRefCount(bodyObjPtr); - cmdPtr->arityMin = arityMin; - cmdPtr->arityMax = arityMax; + cmdPtr->leftArity = leftArity; + cmdPtr->optionalArgs = optionalArgs; + cmdPtr->args = args; + cmdPtr->rightArity = rightArity; cmdPtr->staticVars = NULL; /* Create the statics hash table. */ @@ -9132,27 +9134,30 @@ err: int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, Jim_Obj *const *argv) { - int i, retcode; + int i, d, retcode; Jim_CallFrame *callFramePtr; - int num_args; + Jim_Obj *argObjPtr; + Jim_Obj *procname = argv[0]; /* Check arity */ - if (argc < cmd->arityMin || (cmd->arityMax != -1 && - argc > cmd->arityMax)) { + if (argc - 1 < cmd->leftArity + cmd->rightArity || + (!cmd->args && argc - 1 > cmd->leftArity + cmd->rightArity + cmd->optionalArgs)) { + const char *argList = Jim_GetString(cmd->argListObjPtr, NULL); Jim_Obj *objPtr = Jim_NewEmptyStringObj(interp); Jim_AppendStrings(interp, objPtr, - "wrong # args: should be \"", Jim_GetString(argv[0], NULL), - (cmd->arityMin > 1) ? " " : "", - Jim_GetString(cmd->argListObjPtr, NULL), "\"", NULL); + "wrong # args: should be \"", Jim_GetString(procname, NULL), + (*argList) ? " " : "", argList, "\"", NULL); Jim_SetResult(interp, objPtr); goto err; } + /* Check if there are too nested calls */ if (interp->numLevels == interp->maxNestingDepth) { Jim_SetResultString(interp, "Too many nested calls. Infinite recursion?", -1); goto err; } + /* Create a new callframe */ callFramePtr = JimCreateCallFrame(interp); callFramePtr->parentCallFrame = interp->framePtr; @@ -9166,48 +9171,67 @@ int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, interp->framePtr = callFramePtr; interp->numLevels ++; + /* Simplify arg counting */ + argv++; + argc--; + /* Set arguments */ - num_args = Jim_ListLength(interp, cmd->argListObjPtr); - /* If last argument is 'args', don't set it here */ - if (cmd->arityMax == -1) { - num_args--; + /* Assign in this order: + * leftArity required args. + * rightArity required args + * optionalArgs optional args + * remaining args into 'args' if 'args' + */ + + /* leftArity required args */ + for (i = 0; i < cmd->leftArity; i++) { + Jim_ListIndex(interp, cmd->argListObjPtr, i, &argObjPtr, JIM_NONE); + Jim_SetVariable(interp, argObjPtr, *argv++); + argc--; } + + /* Shorten our idea of the number of supplied args */ + argc -= cmd->rightArity; - for (i = 0; i < num_args; i++) { - Jim_Obj *argObjPtr = 0; - Jim_Obj *nameObjPtr = 0; - Jim_Obj *valueObjPtr = 0; + /* optionalArgs optional args */ + d = i; + for (i = 0; i < cmd->optionalArgs; i++) { + Jim_Obj *nameObjPtr; + Jim_Obj *valueObjPtr; - Jim_ListIndex(interp, cmd->argListObjPtr, i, &argObjPtr, JIM_NONE); - if (i + 1 >= cmd->arityMin) { - /* The name is the first element of the list */ - Jim_ListIndex(interp, argObjPtr, 0, &nameObjPtr, JIM_NONE); + Jim_ListIndex(interp, cmd->argListObjPtr, d++, &argObjPtr, JIM_NONE); + + /* The name is the first element of the list */ + Jim_ListIndex(interp, argObjPtr, 0, &nameObjPtr, JIM_NONE); + if (argc) { + valueObjPtr = *argv++; + argc--; } else { - /* The element arg is the name */ - nameObjPtr = argObjPtr; - } - - if (i + 1 >= argc) { /* No more values, so use default */ /* The value is the second element of the list */ Jim_ListIndex(interp, argObjPtr, 1, &valueObjPtr, JIM_NONE); } - else { - valueObjPtr = argv[i+1]; - } Jim_SetVariable(interp, nameObjPtr, valueObjPtr); } - /* Set optional arguments */ - if (cmd->arityMax == -1) { - Jim_Obj *listObjPtr, *objPtr = 0; - i++; - listObjPtr = Jim_NewListObj(interp, argv+i, argc-i); - Jim_ListIndex(interp, cmd->argListObjPtr, num_args, &objPtr, JIM_NONE); - Jim_SetVariable(interp, objPtr, listObjPtr); + /* Any remaining args go to 'args' */ + if (cmd->args) { + Jim_Obj *listObjPtr = Jim_NewListObj(interp, argv, argc); + /* Use the 'args' name from the procedure args */ + Jim_ListIndex(interp, cmd->argListObjPtr, d, &argObjPtr, JIM_NONE); + Jim_SetVariable(interp, argObjPtr, listObjPtr); + argv += argc; + d++; } + + /* rightArity required args */ + for (i = 0; i < cmd->rightArity; i++) { + Jim_ListIndex(interp, cmd->argListObjPtr, d++, &argObjPtr, JIM_NONE); + Jim_SetVariable(interp, argObjPtr, *argv++); + } + /* Eval the body */ retcode = Jim_EvalObj(interp, cmd->bodyObjPtr); @@ -9241,7 +9265,7 @@ int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc, err: retcode = JIM_ERR_ADDSTACK; Jim_DecrRefCount(interp, interp->errorProc); - interp->errorProc = argv[0]; + interp->errorProc = procname; Jim_IncrRefCount(interp->errorProc); } return retcode; @@ -11333,65 +11357,74 @@ static int Jim_ProcCoreCommand(Jim_Interp *interp, int argc, Jim_Obj *const *argv) { int argListLen; - int arityMin, arityMax; + int leftArity, rightArity; int i; + int optionalArgs = 0; + int args = 0; if (argc != 4 && argc != 5) { Jim_WrongNumArgs(interp, 1, argv, "name arglist ?statics? body"); return JIM_ERR; } argListLen = Jim_ListLength(interp, argv[2]); - arityMin = arityMax = argListLen+1; + leftArity = 0; + rightArity = 0; - if (argListLen) { - const char *str; + /* Examine the argument list for default parameters and 'args' */ + for (i = 0; i < argListLen; i++) { + Jim_Obj *argPtr; int len; - Jim_Obj *argPtr = 0; - - /* Check for 'args' and adjust arityMin and arityMax if necessary */ - Jim_ListIndex(interp, argv[2], argListLen-1, &argPtr, JIM_NONE); - str = Jim_GetString(argPtr, &len); - if (len == 4 && memcmp(str, "args", 4) == 0) { - arityMin--; - arityMax = -1; - } - /* Check for default arguments and reduce arityMin if necessary */ - while (arityMin > 1) { - int len; - Jim_ListIndex(interp, argv[2], arityMin - 2, &argPtr, JIM_NONE); - len = Jim_ListLength(interp, argPtr); - if (len != 2) { - /* No default argument */ - break; + Jim_ListIndex(interp, argv[2], i, &argPtr, JIM_NONE); + if (Jim_CompareStringImmediate(interp, argPtr, "args")) { + if (args) { + Jim_SetResultString(interp, "procedure has 'args' specified more than once", -1); + return JIM_ERR; } - arityMin--; - } - for (i = 0; i < argListLen; i++) { - int len; - Jim_ListIndex(interp, argv[2], i, &argPtr, JIM_NONE); - Jim_GetString(argPtr, &len); - len = Jim_ListLength(interp, argPtr); - if (len == 0) { - Jim_SetResultString(interp, "", 0); - Jim_AppendStrings(interp, Jim_GetResult(interp), - "procedure \"", Jim_GetString(argv[1], NULL), "\" has argument with no name", NULL); + if (rightArity) { + Jim_SetResultString(interp, "procedure has 'args' in invalid position", -1); return JIM_ERR; } - if (len > 2) { - Jim_SetResultString(interp, "", 0); - Jim_AppendStrings(interp, Jim_GetResult(interp), - "too many fields in argument specifier \"", Jim_GetString(argPtr, NULL), "\"", NULL); + args = 1; + continue; + } + + /* Does this parameter have a default? */ + Jim_GetString(argPtr, NULL); + len = Jim_ListLength(interp, argPtr); + if (len == 0) { + Jim_SetResultString(interp, "procedure has argument with no name", -1); + return JIM_ERR; + } + if (len > 2) { + Jim_SetResultString(interp, "procedure has argument with too many fields", -1); + return JIM_ERR; + } + if (len == 1) { + /* A required arg. Is it part of leftArity or rightArity? */ + if (optionalArgs || args) { + rightArity++; + } + else { + leftArity++; + } + } + else { + /* Optional arg. Can't be after rightArity */ + if (rightArity || args) { + Jim_SetResultString(interp, "procedure has optional arg in invalid position", -1); return JIM_ERR; } + optionalArgs++; } } + if (argc == 4) { return Jim_CreateProcedure(interp, Jim_GetString(argv[1], NULL), - argv[2], NULL, argv[3], arityMin, arityMax); + argv[2], NULL, argv[3], leftArity, optionalArgs, args, rightArity); } else { return Jim_CreateProcedure(interp, Jim_GetString(argv[1], NULL), - argv[2], argv[3], argv[4], arityMin, arityMax); + argv[2], argv[3], argv[4], leftArity, optionalArgs, args, rightArity); } } @@ -475,8 +475,10 @@ typedef struct Jim_Cmd { Jim_Obj *argListObjPtr; Jim_Obj *bodyObjPtr; Jim_HashTable *staticVars; /* Static vars hash table. NULL if no statics. */ - int arityMin; /* Min number of arguments. */ - int arityMax; /* Max number of arguments. */ + int leftArity; /* Required args assigned from the left */ + int optionalArgs; /* Number of optional args (default values) */ + int rightArity; /* Required args assigned from the right */ + int args; /* True if 'args' specified */ } Jim_Cmd; /* Pseudo Random Number Generator State structure */ @@ -704,9 +706,9 @@ JIM_EXPORT void Jim_RegisterCoreCommands (Jim_Interp *interp); JIM_EXPORT int Jim_CreateCommand (Jim_Interp *interp, const char *cmdName, Jim_CmdProc cmdProc, void *privData, Jim_DelCmdProc delProc); -JIM_EXPORT int Jim_CreateProcedure (Jim_Interp *interp, - const char *cmdName, Jim_Obj *argListObjPtr, Jim_Obj *staticsListObjPtr, - Jim_Obj *bodyObjPtr, int arityMin, int arityMax); +JIM_EXPORT int Jim_CreateProcedure(Jim_Interp *interp, const char *cmdName, + Jim_Obj *argListObjPtr, Jim_Obj *staticsListObjPtr, Jim_Obj *bodyObjPtr, + int leftArity, int defaultArgs, int argsPos, int rightArity); JIM_EXPORT int Jim_DeleteCommand (Jim_Interp *interp, const char *cmdName); JIM_EXPORT int Jim_RenameCommand (Jim_Interp *interp, diff --git a/tests/proc-new.test b/tests/proc-new.test new file mode 100644 index 0000000..324a976 --- /dev/null +++ b/tests/proc-new.test @@ -0,0 +1,79 @@ +source testing.tcl + +proc aproc {} { + list +} +proc bproc {b} { + list b $b +} +proc cproc {b c} { + list b $b c $c +} +proc dproc {b c {d dd}} { + list b $b c $c d $d +} +proc eproc {b c {d dd} e} { + list b $b c $c d $d e $e +} +proc fproc {b c {d dd} args} { + list b $b c $c d $d args $args +} +proc gproc {b c {d dd} args e} { + list b $b c $c d $d args $args e $e +} +proc hproc {{a aa} args} { + list a $a args $args +} + +section "Proc - TIP #288" + +set n 1 +foreach {proc params result} { + aproc {} {} + bproc B {b B} + cproc {B C} {b B c C} + dproc {B C} {b B c C d dd} + dproc {B C D} {b B c C d D} + eproc {B C D E} {b B c C d D e E} + eproc {B C E} {b B c C d dd e E} + fproc {B C} {b B c C d dd args {}} + fproc {B C D} {b B c C d D args {}} + fproc {B C D E} {b B c C d D args E} + fproc {B C D E F} {b B c C d D args {E F}} + gproc {B C E} {b B c C d dd args {} e E} + gproc {B C D E} {b B c C d D args {} e E} + gproc {B C D X E} {b B c C d D args X e E} + gproc {B C D X Y Z E} {b B c C d D args {X Y Z} e E} + hproc {} {a aa args {}} + hproc {A} {a A args {}} + hproc {A X Y Z} {a A args {X Y Z}} +} { + test proc-1.$n "Proc args combos" [list $proc {*}$params] $result + incr n +} + +proc onearg_search {{nocase ""} value list} { + lsearch {*}$nocase $list $value +} + +proc multiarg_search {args value list} { + lsearch {*}$args $list $value +} + +test proc-2.1 "Real test of optional switches" { + onearg_search c {A a B b C c D d} +} 5 + +test proc-2.2 "Real test of optional switches" { + onearg_search -nocase c {A a B b C c D d} +} 4 + +test proc-2.3 "Real test of optional switches" { + multiarg_search -glob c* {A a B b C c D d} +} 5 + +test proc-2.4 "Real test of optional switches" { + multiarg_search -nocase -glob c* {A a B b C c D d} +} 4 + +testreport diff --git a/tests/proc.test b/tests/proc.test index 2e65c35..56ed59a 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -174,14 +174,15 @@ test proc-old-3.7 {arguments and defaults} { } list [catch {tproc} msg] } {1} +# Note: This requires new TIP #288 support test proc-old-3.8 {arguments and defaults} { list [catch { proc tproc {x {y y-default} z} { return [list $x $y $z] } tproc 2 3 - } msg] -} {1} + } msg] $msg +} {0 {2 y-default 3}} test proc-old-3.9 {arguments and defaults} { proc tproc {x {y y-default} args} { return [list $x $y $args] @@ -246,13 +247,13 @@ test proc-old-5.3 {error conditions} { test proc-old-5.5 {error conditions} { list [catch {proc tproc {{} y} {return foo}} msg] $msg -} {1 {procedure "tproc" has argument with no name}} +} {1 {procedure has argument with no name}} test proc-old-5.6 {error conditions} { list [catch {proc tproc {{} y} {return foo}} msg] $msg -} {1 {procedure "tproc" has argument with no name}} +} {1 {procedure has argument with no name}} test proc-old-5.7 {error conditions} { list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg -} {1 {too many fields in argument specifier "x 1 2"}} +} {1 {procedure has argument with too many fields}} test proc-old-5.8 {error conditions} { catch {return} } 2 diff --git a/tests/testing.tcl b/tests/testing.tcl index 221d6be..a675c5e 100644 --- a/tests/testing.tcl +++ b/tests/testing.tcl @@ -38,13 +38,20 @@ set testresults(numpass) 0 set testresults(failed) {} proc test {id descr script expected} { - puts -nonewline "$id " + if {!$::testquiet} { + puts -nonewline "$id " + } set rc [catch {uplevel 1 $script} result] # Note that rc=2 is return if {($rc == 0 || $rc == 2) && $result eq $expected} { - puts "OK $descr" + if {!$::testquiet} { + puts "OK $descr" + } incr ::testresults(numpass) } else { + if {$::testquiet} { + puts -nonewline "$id " + } puts "ERR $descr" puts "Expected: '$expected'" puts "Got : '$result'" @@ -71,3 +78,5 @@ proc testerror {} { puts [string repeat = 40] puts $argv0 puts [string repeat = 40] + +set ::testquiet [info exists ::env(testquiet)] |