aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xconfigure2
-rw-r--r--configure.ac2
-rw-r--r--glob.tcl158
-rw-r--r--jim.c97
-rw-r--r--jim.h.in1
-rw-r--r--stdlib.tcl40
-rw-r--r--tclcompat.tcl9
-rw-r--r--tests/alias.test123
-rw-r--r--tests/case.test20
-rw-r--r--tests/proc.test2
10 files changed, 350 insertions, 104 deletions
diff --git a/configure b/configure
index e43537b..819189e 100755
--- a/configure
+++ b/configure
@@ -3395,7 +3395,7 @@ if test "${enable_math+set}" = set; then :
fi
-jim_extensions="load package readdir glob array clock exec file posix regexp signal tclcompat aio bio eventloop syslog"
+jim_extensions="stdlib load package readdir glob array clock exec file posix regexp signal tclcompat aio bio eventloop syslog"
# Check whether --with-jim-ext was given.
if test "${with_jim_ext+set}" = set; then :
diff --git a/configure.ac b/configure.ac
index 45f55ab..befc2b3 100644
--- a/configure.ac
+++ b/configure.ac
@@ -40,7 +40,7 @@ AC_ARG_ENABLE(math,
]
)
-jim_extensions="load package readdir glob array clock exec file posix regexp signal tclcompat aio bio eventloop syslog"
+jim_extensions="stdlib load package readdir glob array clock exec file posix regexp signal tclcompat aio bio eventloop syslog"
AC_ARG_WITH(jim-ext,
[ --with-jim-ext specify jim extensions to build (or all, which is the default)],
[
diff --git a/glob.tcl b/glob.tcl
index 8288bc1..dbad26e 100644
--- a/glob.tcl
+++ b/glob.tcl
@@ -6,98 +6,100 @@
# See LICENCE in this directory for full details.
-# If $dir is a directory, return a list of all entries
-# it contains which match $pattern
+# Implements the Tcl glob command
#
-proc _glob_readdir_pattern {dir pattern} {
- set result {}
+# Usage: glob ?-nocomplain? pattern ...
+#
+# Patterns use 'string match' (glob) pattern matching for each
+# directory level, plus support for braced alternations.
+#
+# e.g. glob "te[a-e]*/*.{c,tcl}"
+#
+# Note: files starting with . will only be returned if matching component
+# of the pattern starts with .
+proc glob {args} {
- # readdir doesn't return . or .., so simulate it here
- if {$pattern in {. ..}} {
- return $pattern
- }
+ # If $dir is a directory, return a list of all entries
+ # it contains which match $pattern
+ #
+ local proc glob.readdir_pattern {dir pattern} {
+ set result {}
- # Use -nocomplain here to return nothing if $dir is not a directory
- foreach name [readdir -nocomplain $dir] {
- if {[string match $pattern $name]} {
- # Only include entries starting with . if the pattern starts with .
- if {[string index $name 0] eq "." && [string index $pattern 0] ne "."} {
- continue
- }
- lappend result $name
+ # readdir doesn't return . or .., so simulate it here
+ if {$pattern in {. ..}} {
+ return $pattern
}
- }
- return $result
-}
+ # Use -nocomplain here to return nothing if $dir is not a directory
+ foreach name [readdir -nocomplain $dir] {
+ if {[string match $pattern $name]} {
+ # Only include entries starting with . if the pattern starts with .
+ if {[string index $name 0] eq "." && [string index $pattern 0] ne "."} {
+ continue
+ }
+ lappend result $name
+ }
+ }
-# glob entries in directory $dir and pattern $rem
-#
-proc _glob_do {dir rem} {
- # Take one level from rem
- # Avoid regexp here
- set i [string first / $rem]
- if {$i < 0} {
- set pattern $rem
- set rempattern ""
- } else {
- set pattern [string range $rem 0 $i-1]
- set rempattern [string range $rem $i+1 end]
+ return $result
}
- # Determine the appropriate separator and globbing dir
- set sep /
- set globdir $dir
- if {[string match "*/" $dir]} {
- set sep ""
- } elseif {$dir eq ""} {
- set globdir .
- set sep ""
- }
+ # glob entries in directory $dir and pattern $rem
+ #
+ local proc glob.do {dir rem} {
+ # Take one level from rem
+ # Avoid regexp here
+ set i [string first / $rem]
+ if {$i < 0} {
+ set pattern $rem
+ set rempattern ""
+ } else {
+ set pattern [string range $rem 0 $i-1]
+ set rempattern [string range $rem $i+1 end]
+ }
- set result {}
+ # Determine the appropriate separator and globbing dir
+ set sep /
+ set globdir $dir
+ if {[string match "*/" $dir]} {
+ set sep ""
+ } elseif {$dir eq ""} {
+ set globdir .
+ set sep ""
+ }
- # If the pattern contains a braced expression, recursively call _glob_do
- # to expand the alternations. Avoid regexp for dependency reasons.
- # XXX: Doesn't handle backslashed braces
- if {[set fb [string first "\{" $pattern]] >= 0} {
- if {[set nb [string first "\}" $pattern $fb]] >= 0} {
- set before [string range $pattern 0 $fb-1]
- set braced [string range $pattern $fb+1 $nb-1]
- set after [string range $pattern $nb+1 end]
-
- foreach part [split $braced ,] {
- lappend result {*}[_glob_do $dir $before$part$after]
+ set result {}
+
+ # If the pattern contains a braced expression, recursively call glob.do
+ # to expand the alternations. Avoid regexp for dependency reasons.
+ # XXX: Doesn't handle backslashed braces
+ if {[set fb [string first "\{" $pattern]] >= 0} {
+ if {[set nb [string first "\}" $pattern $fb]] >= 0} {
+ set before [string range $pattern 0 $fb-1]
+ set braced [string range $pattern $fb+1 $nb-1]
+ set after [string range $pattern $nb+1 end]
+
+ foreach part [split $braced ,] {
+ lappend result {*}[glob.do $dir $before$part$after]
+ }
+ return $result
}
- return $result
}
- }
- # Use readdir and select all files which match the pattern
- foreach f [_glob_readdir_pattern $globdir $pattern] {
- if {$rempattern eq ""} {
- # This is a terminal entry, so add it
- lappend result $dir$sep$f
- } else {
- # Expany any entries at this level and add them
- lappend result {*}[_glob_do $dir$sep$f $rempattern]
+ # Use readdir and select all files which match the pattern
+ foreach f [glob.readdir_pattern $globdir $pattern] {
+ if {$rempattern eq ""} {
+ # This is a terminal entry, so add it
+ lappend result $dir$sep$f
+ } else {
+ # Expany any entries at this level and add them
+ lappend result {*}[glob.do $dir$sep$f $rempattern]
+ }
}
+ return $result
}
- return $result
-}
-# Implements the Tcl glob command
-#
-# Usage: glob ?-nocomplain? pattern ...
-#
-# Patterns use 'string match' (glob) pattern matching for each
-# directory level, plus support for braced alternations.
-#
-# e.g. glob "te[a-e]*/*.{c,tcl}"
-#
-# Note: files starting with . will only be returned if matching component
-# of the pattern starts with .
-proc glob {args} {
+ # Start of main glob
set nocomplain 0
if {[lindex $args 0] eq "-nocomplain"} {
@@ -110,9 +112,9 @@ proc glob {args} {
if {$pattern eq "/"} {
lappend result /
} elseif {[string match "/*" $pattern]} {
- lappend result {*}[_glob_do / [string range $pattern 1 end]]
+ lappend result {*}[glob.do / [string range $pattern 1 end]]
} else {
- lappend result {*}[_glob_do "" $pattern]
+ lappend result {*}[glob.do "" $pattern]
}
}
diff --git a/jim.c b/jim.c
index 3ee76e9..f13a4b6 100644
--- a/jim.c
+++ b/jim.c
@@ -115,6 +115,7 @@ static int ListSetIndex(Jim_Interp *interp, Jim_Obj *listPtr, int index, Jim_Obj
static Jim_Obj *Jim_ExpandDictSugar(Jim_Interp *interp, Jim_Obj *objPtr);
static void SetDictSubstFromAny(Jim_Interp *interp, Jim_Obj *objPtr);
static void JimSetFailedEnumResult(Jim_Interp *interp, const char *arg, const char *badtype, const char *prefix, const char * const *tablePtr, const char *name);
+static void JimDeleteLocalProcs(Jim_Interp *interp);
static const Jim_HashTableType JimVariablesHashTableType;
@@ -3229,6 +3230,9 @@ int Jim_CreateProcedure(Jim_Interp *interp, const char *cmdName,
* can never affect existing cached commands. We don't do
* negative caching. */
Jim_AddHashEntry(&interp->commands, cmdName, cmdPtr);
+
+ /* Unlike Tcl, set the name of the proc as the result */
+ Jim_SetResultString(interp, cmdName, -1);
return JIM_OK;
err:
@@ -4399,6 +4403,7 @@ Jim_Interp *Jim_CreateInterp(void)
i->sigmask = 0;
i->signal_level = 0;
i->signal_set_result = NULL;
+ i->localProcs = NULL;
/* Note that we can create objects only after the
* interpreter liveList and freeList pointers are
@@ -4456,6 +4461,8 @@ void Jim_FreeInterp(Jim_Interp *i)
Jim_FreeHashTable(&i->assocData);
Jim_FreeHashTable(&i->packages);
Jim_Free(i->prngState);
+ JimDeleteLocalProcs(i);
+
/* Free the call frames list */
while(cf) {
prevcf = cf->parentCallFrame;
@@ -8881,6 +8888,22 @@ static void JimAddErrorToStack(Jim_Interp *interp, int retcode, const char *file
}
}
+/* And delete any local procs */
+static void JimDeleteLocalProcs(Jim_Interp *interp)
+{
+ if (interp->localProcs) {
+ char *procname;
+
+ while ((procname = Jim_StackPop(interp->localProcs)) != NULL) {
+ Jim_DeleteCommand(interp, procname);
+ Jim_Free(procname);
+ }
+ Jim_FreeStack(interp->localProcs);
+ Jim_Free(interp->localProcs);
+ interp->localProcs = NULL;
+ }
+}
+
int Jim_EvalObj(Jim_Interp *interp, Jim_Obj *scriptObjPtr)
{
int i, j = 0, len;
@@ -9107,6 +9130,7 @@ err:
}
if (argv != sargv)
Jim_Free(argv);
+
return retcode;
}
@@ -9125,6 +9149,7 @@ int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc,
Jim_CallFrame *callFramePtr;
Jim_Obj *argObjPtr;
Jim_Obj *procname = argv[0];
+ Jim_Stack *prevLocalProcs;
/* Check arity */
if (argc - 1 < cmd->leftArity + cmd->rightArity ||
@@ -9239,9 +9264,17 @@ int JimCallProcedure(Jim_Interp *interp, Jim_Cmd *cmd, int argc,
Jim_SetVariable(interp, argObjPtr, *argv++);
}
+ /* Install a new stack for local procs */
+ prevLocalProcs = interp->localProcs;
+ interp->localProcs = NULL;
+
/* Eval the body */
retcode = Jim_EvalObj(interp, cmd->bodyObjPtr);
+ /* Delete any local procs */
+ JimDeleteLocalProcs(interp);
+ interp->localProcs = prevLocalProcs;
+
/* Destroy the callframe */
interp->numLevels --;
interp->framePtr = interp->framePtr->parentCallFrame;
@@ -9362,6 +9395,7 @@ int Jim_EvalFile(Jim_Interp *interp, const char *filename)
char *buf;
Jim_Obj *scriptObjPtr;
Jim_Obj *prevScriptObj;
+ Jim_Stack *prevLocalProcs;
struct stat sb;
int retcode;
int readlen;
@@ -9391,8 +9425,16 @@ int Jim_EvalFile(Jim_Interp *interp, const char *filename)
prevScriptObj = interp->currentScriptObj;
interp->currentScriptObj = scriptObjPtr;
+ /* Install a new stack for local procs */
+ prevLocalProcs = interp->localProcs;
+ interp->localProcs = NULL;
+
retcode = Jim_EvalObj(interp, scriptObjPtr);
+ /* Delete any local procs */
+ JimDeleteLocalProcs(interp);
+ interp->localProcs = prevLocalProcs;
+
/* Handle the JIM_RETURN return code */
if (retcode == JIM_RETURN) {
if (--interp->returnLevel <= 0) {
@@ -11147,17 +11189,28 @@ static int Jim_EvalCoreCommand(Jim_Interp *interp, int argc,
Jim_Obj *const *argv)
{
int rc;
+ Jim_Stack *prevLocalProcs;
if (argc < 2) {
Jim_WrongNumArgs(interp, 1, argv, "script ?...?");
return JIM_ERR;
}
+
+ /* Install a new stack for local procs */
+ prevLocalProcs = interp->localProcs;
+ interp->localProcs = NULL;
+
if (argc == 2) {
rc = Jim_EvalObj(interp, argv[1]);
}
else {
rc = Jim_EvalObj(interp, Jim_ConcatObj(interp, argc-1, argv+1));
}
+
+ /* Delete any local procs */
+ JimDeleteLocalProcs(interp);
+ interp->localProcs = prevLocalProcs;
+
if (rc == JIM_ERR) {
/* eval is "interesting", so add a stack frame here */
interp->addStackTrace++;
@@ -11402,6 +11455,31 @@ static int Jim_ProcCoreCommand(Jim_Interp *interp, int argc,
}
}
+/* [local] */
+static int Jim_LocalCoreCommand(Jim_Interp *interp, int argc,
+ Jim_Obj *const *argv)
+{
+ /* Evaluate the arguments */
+ int retcode = Jim_EvalObjVector(interp, argc - 1, argv + 1);
+
+ /* If OK, and the result is a proc, add it to the list of local procs */
+ if (retcode == 0) {
+ const char *procname = Jim_GetString(Jim_GetResult(interp), NULL);
+ if (Jim_FindHashEntry(&interp->commands, procname) == NULL) {
+ Jim_SetResultFormatted(interp, "not a proc: \"%s\"", procname);
+ return JIM_ERR;
+ }
+ if (interp->localProcs == NULL) {
+ interp->localProcs = Jim_Alloc(sizeof(*interp->localProcs));
+ Jim_InitStack(interp->localProcs);
+ }
+ Jim_StackPush(interp->localProcs, Jim_StrDup(procname));
+ }
+
+ return retcode;
+}
+
+
/* [concat] */
static int Jim_ConcatCoreCommand(Jim_Interp *interp, int argc,
Jim_Obj *const *argv)
@@ -12823,26 +12901,10 @@ static const struct {
{"range", Jim_RangeCoreCommand},
{"rand", Jim_RandCoreCommand},
{"tailcall", Jim_TailcallCoreCommand},
+ {"local", Jim_LocalCoreCommand},
{NULL, NULL},
};
-/* Some Jim core command is actually a procedure written in Jim itself. */
-static void Jim_RegisterCoreProcedures(Jim_Interp *interp)
-{
-#ifdef JIM_REFERENCES
- Jim_Eval(interp,
-"proc lambda {arglist args} {\n"
-" set name [ref {} function lambdaFinalizer]\n"
-" uplevel 1 [list proc $name $arglist {expand}$args]\n"
-" return $name\n"
-"}\n"
-"proc lambdaFinalizer {name val} {\n"
-" rename $name {}\n"
-"}\n"
- );
-#endif
-}
-
void Jim_RegisterCoreCommands(Jim_Interp *interp)
{
int i = 0;
@@ -12854,7 +12916,6 @@ void Jim_RegisterCoreCommands(Jim_Interp *interp)
NULL, NULL);
i++;
}
- Jim_RegisterCoreProcedures(interp);
}
/* -----------------------------------------------------------------------------
diff --git a/jim.h.in b/jim.h.in
index a9fc9d4..a02a045 100644
--- a/jim.h.in
+++ b/jim.h.in
@@ -541,6 +541,7 @@ typedef struct Jim_Interp {
struct Jim_HashTable assocData; /* per-interp storage for use by packages */
Jim_PrngState *prngState; /* per interpreter Random Number Gen. state. */
struct Jim_HashTable packages; /* Provided packages hash table */
+ Jim_Stack *localProcs; /* procs to be destroyed on end of evaluation */
} Jim_Interp;
/* Currently provided as macro that performs the increment.
diff --git a/stdlib.tcl b/stdlib.tcl
new file mode 100644
index 0000000..e406a4f
--- /dev/null
+++ b/stdlib.tcl
@@ -0,0 +1,40 @@
+# Create a single word alias (proc) for one or more words
+# e.g. alias x info exists
+# if {[x var]} ...
+proc alias {name args} {
+ set prefix $args
+ proc $name args prefix {
+ uplevel 1 $prefix $args
+ }
+}
+
+# Creates an anonymous procedure
+proc lambda {arglist args} {
+ set name [ref {} function lambda.finalizer]
+ uplevel 1 [list proc $name $arglist {*}$args]
+ return $name
+}
+
+proc lambda.finalizer {name val} {
+ rename $name {}
+}
+
+# Like alias, but creates and returns an anonyous procedure
+proc curry {args} {
+ set prefix $args
+ lambda args prefix {
+ uplevel 1 $prefix $args
+ }
+}
+
+# Returns the given argument.
+# Useful with 'local' as follows:
+# proc a {} {...}
+# local function a
+#
+# set x [lambda ...]
+# local function $x
+#
+proc function {value} {
+ return $value
+}
diff --git a/tclcompat.tcl b/tclcompat.tcl
index b631ae0..58dee97 100644
--- a/tclcompat.tcl
+++ b/tclcompat.tcl
@@ -34,20 +34,20 @@ proc case {var args} {
}
# Internal function to match a value agains a list of patterns
- set checker [lambda {value pattern} {string match $pattern $value}]
+ local proc case.checker {value pattern} {
+ string match $pattern $value
+ }
foreach {value action} $args {
if {$value eq "default"} {
set do_action $action
continue
- } elseif {[lsearch -bool -command $checker $value $var]} {
+ } elseif {[lsearch -bool -command case.checker $value $var]} {
set do_action $action
break
}
}
- rename $checker ""
-
if {[info exists do_action]} {
set rc [catch [list uplevel 1 $do_action] result opts]
if {$rc} {
@@ -214,5 +214,4 @@ proc throw {code {msg ""}} {
return -code $code $msg
}
-
set ::tcl_platform(platform) unix
diff --git a/tests/alias.test b/tests/alias.test
new file mode 100644
index 0000000..94aa4f1
--- /dev/null
+++ b/tests/alias.test
@@ -0,0 +1,123 @@
+source testing.tcl
+
+test alias-1.1 "One word alias" {
+ set x 2
+ alias newincr incr
+ newincr x
+} {3}
+
+test alias-1.4 "Two word alias" {
+ alias infoexists info exists
+ infoexists x
+} {1}
+
+test alias-1.5 "Replace alias" {
+ alias newincr infoexists
+ newincr x
+} {1}
+
+test alias-1.6 "Delete alias" {
+ rename newincr ""
+ catch {newincr x}
+} {1}
+
+test alias-1.7 "Replace alias with proc" {
+ proc infoexists {n} {
+ return yes
+ }
+ infoexists any
+} {yes}
+
+test alias-1.8 "Replace proc with alias" {
+ alias infoexists info exists
+ infoexists any
+} {0}
+
+test curry-1.1 "One word curry" {
+ set x 2
+ set one [curry incr]
+ $one x
+} {3}
+
+test curry-1.4 "Two word curry" {
+ set two [curry info exists]
+ list [$two x] [$two y]
+} {1 0}
+
+test curry-1.5 "Delete curry" {
+ unset one two
+ collect
+} {2}
+
+test local-1.1 "local lambda in eval" {
+ set x 1
+ eval {
+ local set a [lambda {b} { incr b }]
+ set x [$a $x]
+ }
+ list [info procs $a] $x
+} {{} 2}
+
+test local-1.2 "local curry in proc" {
+ proc a {} {
+ local set p [curry info exists]
+ set x 1
+ list $p [$p x] [$p y]
+ }
+ lassign [a] p exists_x exists_y
+ list [info procs $p] $exists_x $exists_y
+} {{} 1 0}
+
+test local-1.2 "set local curry in proc" {
+ proc a {} {
+ set p [local curry info exists]
+ set x 1
+ list $p [$p x] [$p y]
+ }
+ lassign [a] p exists_x exists_y
+ list [info procs $p] $exists_x $exists_y
+} {{} 1 0}
+
+test local-1.3 "local alias in proc" {
+ proc a {} {
+ local alias p info exists
+ set x 1
+ list [p x] [p y]
+ }
+ lassign [a] exists_x exists_y
+ list [info procs p] $exists_x $exists_y
+} {{} 1 0}
+
+test local-1.5 "local proc in proc" {
+ set ::x 1
+ proc a {} {
+ local proc b {} { incr ::x }
+ b
+ set ::x
+ }
+ a
+ list [info procs b] $::x
+} {{} 2}
+
+test local-1.6 "local lambda in lsort" {
+ lsort -command [local lambda {a b} {string compare $a $b}] {d a f g}
+} {a d f g}
+
+test local-1.7 "check no reference procs" {
+ info procs "<reference*"
+} {}
+
+test local-1.8 "local on non-proc" {
+ list [catch {local set x blah} msg] $msg
+} {1 {not a proc: "blah"}}
+
+test local-1.9 "local on existing proc" {
+ eval {
+ proc a {b} {incr b}
+ local function a
+ set c [lambda b {incr b -1}]
+ local function $c
+ lappend result [a 1] [$c 2]
+ }
+ list [info procs a] $result
+} {{} {2 1}}
diff --git a/tests/case.test b/tests/case.test
index 4a594ad..a774004 100644
--- a/tests/case.test
+++ b/tests/case.test
@@ -1,5 +1,25 @@
source testing.tcl
+test case-1.1 "Simple case" {
+ foreach c {abc xyz def sdfbc basdf a aba} {
+ case $c in {
+ b* {
+ lappend result 1
+ }
+ {ab a} {
+ lappend result 2
+ }
+ {def *bc} {
+ lappend result 3
+ }
+ default {
+ lappend result 4
+ }
+ }
+ }
+ set result
+} {3 4 3 3 1 2 4}
+
# case is a proc, but it should be able
# to cause a return in do_case
proc do_case {var} {
diff --git a/tests/proc.test b/tests/proc.test
index 56ed59a..985f68b 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -30,7 +30,7 @@ proc tproc x {
test proc-old-1.2 {simple procedure call and return} {tproc 2} 3
test proc-old-1.3 {simple procedure call and return} {
proc tproc {} {return foo}
-} {}
+} {tproc}
test proc-old-1.4 {simple procedure call and return} {
proc tproc {} {return}
tproc
generated by cgit v1.1 at 2024-08-19 01:45:41 +0000