First implementation of TIP#329

2 files changed, 222 insertions, 19 deletions

diff --git a/ChangeLog b/ChangeLog
index 9c45911..d86c96a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2008-12-16  Donal K. Fellows  <dkf@users.sf.net>
+
+	TIP #329 IMPLEMENTATION
+
+	* library/init.tcl (throw, try): Implementation of commands documented
+	in TIP. This implementation is in Tcl and is a stop-gap until
+	higher-performance ones can be written.
+
 2008-12-16  Don Porter	<dgp@users.sourceforge.net>
 
 	* generic/tcl.h:	Add TIP 338 routines to stub table.
diff --git a/library/init.tcl b/library/init.tcl
index 084ddbc..dfb1777 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
 # Default system startup file for Tcl-based applications.  Defines
 # "unknown" procedure and auto-load facilities.
 #
-# RCS: @(#) $Id: init.tcl,v 1.115 2008/10/16 17:04:58 dgp Exp $
+# RCS: @(#) $Id: init.tcl,v 1.116 2008/12/16 16:36:08 dkf Exp $
 #
 # Copyright (c) 1991-1993 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -113,6 +113,201 @@ namespace eval tcl {
     }
 }
 
+# TIP #329: [try] and [throw]
+# These are *temporary* implementations, to be replaced with ones in C and
+# bytecode at a later date before 8.6.0
+namespace eval ::tcl::control {
+    # These are not local, since this allows us to [uplevel] a [catch] rather
+    # than [catch] the [uplevel]ing of something, resulting in a cleaner
+    # -errorinfo:
+    variable em {}
+    variable opts {}
+
+    variable magicCodes { ok 0 error 1 return 2 break 3 continue 4 }
+
+    namespace export throw try
+
+    # ::tcl::control::throw --
+    #
+    #	Creates an error with machine-readable "code" parts and
+    #	human-readable "message" parts.
+    #
+    # Arguments:
+    #	throw -		list describing errorcode
+    #	message -	Human-readable version of error
+    proc throw {type message} {
+	return -code error -errorcode $type -errorinfo $message -level 1 \
+	    $message
+    }
+
+    # ::tcl::control::try --
+    #
+    #	Advanced error handling construct.
+    #
+    # Arguments:
+    #	See try(n) for details
+    proc try {args} {
+	variable magicCodes
+
+	# ----- Parse arguments -----
+
+	set trybody [lindex $args 0]
+	set finallybody {}
+	set handlers [list]
+	set i 1
+
+	while {$i < [llength $args]} {
+	    switch -- [lindex $args $i] {
+		"on" {
+		    incr i
+		    set code [lindex $args $i]
+		    if {[dict exists $magicCodes $code]} {
+			set code [dict get $magicCodes $code]
+		    } elseif {![string is integer -strict $code]} {
+			set msgPart [join [dict keys $magicCodes] {", "}]
+			error "bad code '[lindex $args $i]': must be\
+			    integer or \"$msgPart\""
+		    }
+		    lappend handlers [lrange $args $i $i] \
+			[format %d $code] {} {*}[lrange $args $i+1 $i+2]
+		    incr i 3
+		}
+		"trap" {
+		    incr i
+		    if {![string is list [lindex $args $i]]} {
+			error "bad prefix '[lindex $args $i]':\
+			    must be a list"
+		    }
+		    lappend handlers [lrange $args $i $i] 1 \
+			{*}[lrange $args $i+1 $i+2]
+		    incr i 3
+		}
+		"finally" {
+		    incr i
+		    set finallybody [lindex $args $i]
+		    incr i
+		    break
+		}
+		default {
+		    error "bad handler '[lindex $args $i]': must be\
+			\"on code varlist body\", or\
+			\"trap prefix varlist body\""
+		}
+	    }
+	}
+
+	if {($i != [llength $args]) || ([lindex $handlers end] eq "-")} {
+	    error "wrong # args: should be\
+		\"try body ?handler ...? ?finally body?\""
+	}
+
+	# ----- Execute 'try' body -----
+
+	variable em
+	variable opts
+	set EMVAR  [namespace which -variable em]
+	set OPTVAR [namespace which -variable opts]
+	set code [uplevel 1 [list ::catch $trybody $EMVAR $OPTVAR]]
+
+	if {$code == 1} {
+	    set line [dict get $opts -errorline]
+	    dict append opts -errorinfo \
+		"\n    (\"[lindex [info level 0] 0]\" body line $line)"
+	}
+
+	# Keep track of the original error message & options
+	set _em $em
+	set _opts $opts
+
+	# ----- Find and execute handler -----
+
+	set errorcode {}
+	if {[dict exists $opts -errorcode]} {
+	    set errorcode [dict get $opts -errorcode]
+	}
+	set found false
+	foreach {descrip oncode pattern varlist body} $handlers {
+	    if {!$found} {
+		if {
+		    ($code != $oncode) || ([lrange $pattern 0 end] ne
+		    [lrange $errorcode 0 [llength $pattern]-1] )
+		} then {
+		    continue
+		}
+	    }
+	    set found true
+	    if {$body eq "-"} {
+		continue
+	    }
+
+	    # Handler found ...
+
+	    # Assign trybody results into variables
+	    lassign $varlist resultsVarName optionsVarName
+	    if {[llength $varlist] >= 1} {
+		upvar 1 $resultsVarName resultsvar
+		set resultsvar $em
+	    }
+	    if {[llength $varlist] >= 2} {
+		upvar 1 $optionsVarName optsvar
+		set optsvar $opts
+	    }
+
+	    # Execute the handler
+	    set code [uplevel 1 [list ::catch $body $EMVAR $OPTVAR]]
+
+	    if {$code == 1} {
+		set line [dict get $opts -errorline]
+		dict append opts -errorinfo \
+		    "\n    (\"[lindex [info level 0] 0] ... $descrip\"\
+		    body line $line)"
+		# On error chain to original outcome
+		dict set opts -during $_opts
+	    }
+
+	    # Handler result replaces the original result (whether success or
+	    # failure); capture context of original exception for reference.
+	    set _em $em
+	    set _opts $opts
+
+	    # Handler has been executed - stop looking for more
+	    break
+	}
+
+	# No catch handler found -- error falls through to caller
+	# OR catch handler executed -- result falls through to caller
+
+	# ----- If we have a finally block then execute it -----
+
+	if {$finallybody ne {}} {
+	    set code [uplevel 1 [list ::catch $finallybody $EMVAR $OPTVAR]]
+
+	    # Finally result takes precedence except on success
+
+	    if {$code == 1} {
+		set line [dict get $opts -errorline]
+		dict append opts -errorinfo \
+		    "\n    (\"[lindex [info level 0] 0] ... finally\"\
+		    body line $line)"
+		# On error chain to original outcome
+		dict set opts -during $_opts
+	    }
+	    if {$code != 0} {
+		set _em $em
+		set _opts $opts
+	    }
+
+	    # Otherwise our result is not affected
+	}
+
+	# Propagate the error or the result of the executed catch body to the
+	# caller.
+	dict incr _opts -level
+	return -options $_opts $_em
+    }
+}
+namespace import ::tcl::control::*
+
 # Windows specific end of initialization
 
 if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
@@ -179,9 +374,9 @@ if {[interp issafe]} {
 		-subcommands {
 		    add clicks format microseconds milliseconds scan seconds
 		}]
-	
+
 	# Auto-loading stubs for 'clock.tcl'
-	
+
 	foreach cmd {add format scan} {
 	    proc ::tcl::clock::$cmd args {
 		variable TclLibDir
@@ -276,7 +471,7 @@ proc unknown args {
 	    if {$code ==  1} {
 		#
 		# Compute stack trace contribution from the [uplevel].
-		# Note the dependence on how Tcl_AddErrorInfo, etc. 
+		# Note the dependence on how Tcl_AddErrorInfo, etc.
 		# construct the stack trace.
 		#
 		set errorInfo [dict get $opts -errorinfo]
@@ -407,7 +602,7 @@ proc unknown args {
 # library file to create the procedure.  Returns 1 if it successfully
 # loaded the procedure, 0 otherwise.
 #
-# Arguments: 
+# Arguments:
 # cmd -			Name of the command to find and load.
 # namespace (optional)  The namespace where the command is being used - must be
 #                       a canonical namespace as returned [namespace current]
@@ -431,7 +626,7 @@ proc auto_load {cmd {namespace {}}} {
 	    #    info commands $name
 	    # Unfortunately, if the name has glob-magic chars in it like *
 	    # or [], it may not match.  For our purposes here, a better
-	    # route is to use 
+	    # route is to use
 	    #    namespace which -command $name
 	    if {[namespace which -command $name] ne ""} {
 		return 1
@@ -462,7 +657,7 @@ proc auto_load {cmd {namespace {}}} {
 # of available commands.  Returns 1 if the index is loaded, and 0 if
 # the index is already loaded and up to date.
 #
-# Arguments: 
+# Arguments:
 # None.
 
 proc auto_load_index {} {
@@ -552,7 +747,7 @@ proc auto_qualify {cmd namespace} {
 	    return [list [string range $cmd 2 end]]
 	}
     }
-    
+
     # Potentially returning 2 elements to try  :
     # (if the current namespace is not the global one)
 
@@ -610,13 +805,13 @@ proc auto_import {pattern} {
 
 # auto_execok --
 #
-# Returns string that indicates name of program to execute if 
+# Returns string that indicates name of program to execute if
 # name corresponds to a shell builtin or an executable in the
-# Windows search path, or "" otherwise.  Builds an associative 
-# array auto_execs that caches information about previous checks, 
+# Windows search path, or "" otherwise.  Builds an associative
+# array auto_execs that caches information about previous checks,
 # for speed.
 #
-# Arguments: 
+# Arguments:
 # name -			Name of a command.
 
 if {$tcl_platform(platform) eq "windows"} {
@@ -671,7 +866,7 @@ proc auto_execok name {
 
     set path "[file dirname [info nameof]];.;"
     if {[info exists env(WINDIR)]} {
-	set windir $env(WINDIR) 
+	set windir $env(WINDIR)
     }
     if {[info exists windir]} {
 	if {$tcl_platform(os) eq "Windows NT"} {
@@ -736,13 +931,13 @@ proc auto_execok name {
 # This procedure is called by Tcl's core when attempts to call the
 # filesystem's copydirectory function fail.  The semantics of the call
 # are that 'dest' does not yet exist, i.e. dest should become the exact
-# image of src.  If dest does exist, we throw an error.  
-# 
+# image of src.  If dest does exist, we throw an error.
+#
 # Note that making changes to this procedure can change the results
 # of running Tcl's tests.
 #
-# Arguments: 
-# action -              "renaming" or "copying" 
+# Arguments:
+# action -              "renaming" or "copying"
 # src -			source directory
 # dest -		destination directory
 proc tcl::CopyDirectory {action src dest} {
@@ -770,7 +965,7 @@ proc tcl::CopyDirectory {action src dest} {
 	    # exists, then we should only call this function if -force
 	    # is true, which means we just want to over-write.  So,
 	    # the following code is now commented out.
-	    # 
+	    #
 	    # return -code error "error $action \"$src\" to\
 	    # \"$dest\": file already exists"
 	} else {
@@ -803,7 +998,7 @@ proc tcl::CopyDirectory {action src dest} {
     # Have to be careful to capture both visible and hidden files.
     # We will also be more generous to the file system and not
     # assume the hidden and non-hidden lists are non-overlapping.
-    # 
+    #
     # On Unix 'hidden' files begin with '.'.  On other platforms
     # or filesystems hidden files may have other interpretations.
     set filelist [concat [glob -nocomplain -directory $src *] \