summaryrefslogtreecommitdiffstats
path: root/library/init.tcl
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-03-09 09:12:38 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-03-09 09:12:38 (GMT)
commit0f443aa5cb126f232e2ffb85bb63b1e93f89564c (patch)
tree0ad84f916420342085164f7dfc0af2fa1bc87e2e /library/init.tcl
parente7ae31d6d3e1a343991401b5795fc1b04c6e8236 (diff)
downloadtcl-0f443aa5cb126f232e2ffb85bb63b1e93f89564c.zip
tcl-0f443aa5cb126f232e2ffb85bb63b1e93f89564c.tar.gz
tcl-0f443aa5cb126f232e2ffb85bb63b1e93f89564c.tar.bz2
Move the implementation of [try] from Tcl to C. Not yet bytecoded.
Diffstat (limited to 'library/init.tcl')
-rw-r--r--library/init.tcl184
1 files changed, 1 insertions, 183 deletions
diff --git a/library/init.tcl b/library/init.tcl
index 3ec3079..6ca4873 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.120 2009/01/16 20:44:25 dgp Exp $
+# RCS: @(#) $Id: init.tcl,v 1.121 2009/03/09 09:12:39 dkf Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -113,188 +113,6 @@ namespace eval tcl {
}
}
-# TIP #329: [try]
-# This is a *temporary* implementation, to be replaced with one 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 try
-
- # ::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 $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::try
-
# Windows specific end of initialization
if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {