# stdlib.tcl --
#
# Implementations of the majority of quadcodes in LLVM IR. The
# implementations are generated as mandatory-inline functions that are
# added onto the Builder class, so that it can issue them by just
# generating a call to the implementation function. This allows us to
# inject extra basic blocks without disturbing the analysis from the
# reasoning engine.
#
# See build.tcl for where these functions are called from.
#
# Copyright (c) 2015-2016 by Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#------------------------------------------------------------------------------
oo::define Builder {
# Variables holding implementations of Tcl's string operators
variable tcl.stringify.double tcl.stringify.int tcl.stringify.numeric
variable tcl.addReference tcl.dropReference
variable tcl.addMaybeReference tcl.dropMaybeReference
variable tcl.unshare tcl.unshare.copy
variable tcl.strlen tcl.append.string tcl.streq tcl.strcmp tcl.strmatch
variable tcl.stridx tcl.stridx.idx
variable tcl.strrange tcl.strrange.idx tcl.strreplace tcl.strreplace.idx
variable tcl.strfind.fwd tcl.strfind.rev
variable tcl.strmap tcl.strtrim tcl.strcase tcl.strclass
variable tcl.regexp tcl.concatenate tcl.booleanTest tcl.not.string
variable tcl.resolveCmd tcl.originCmd
# Variables holding implementations of Tcl's list operators
variable tcl.list.create tcl.list.length tcl.list.append tcl.list.concat
variable tcl.list.foreach.getStep tcl.list.foreach.mayStep
variable tcl.list.foreach.nextStep tcl.list.foreach.start tcl.list.unshare
variable tcl.list.range tcl.list.range1 tcl.list.in
variable tcl.list.index tcl.list.index1 tcl.list.indexList
variable tcl.list.set tcl.list.set1 tcl.list.setList
# Variables holding implementations of Tcl's dict operators
variable tcl.dict.get1 tcl.dict.get tcl.dict.set1 tcl.dict.set
variable tcl.dict.exists1 tcl.dict.exists tcl.dict.unset1 tcl.dict.unset
variable tcl.dict.iterStart tcl.dict.iterNext tcl.dict.iterDone
variable tcl.dict.iterKey tcl.dict.iterValue tcl.dict.addIterReference
variable tcl.dict.dropIterReference tcl.dict.dropIterFailReference
variable tcl.dict.append tcl.dict.lappend tcl.dict.incr tcl.dict.size
variable tcl.maptoint
# Variables holding implementations of Tcl's exception-handling machinery
variable tcl.getresult tcl.getreturnopts tcl.initExceptionOptions
variable tcl.initExceptionSimple tcl.processReturn
variable tcl.existsOrError tcl.invoke.command
# Variables holding implementations of Tcl's callframe handling
variable tcl.callframe.init tcl.callframe.makevar tcl.callframe.clear
variable tcl.callframe.store tcl.callframe.load
# Helper functions
variable tcl.impl.trimleft tcl.impl.trimright
variable tcl.impl.getIndex tcl.impl.listDupe
variable var.hash.getValue
variable tcl.read.var.ptr tcl.write.var.ptr tcl.unset.var.ptr
# Reference to the module object
variable m
# Builder:ReferenceFunctions --
#
# Generate the functions that implement Tcl_Obj reference management.
# Only called from @apiFunctions method.
#
# Parameters:
# api - The handle of the Tcl API object (currently an instance of the
# Thunk class).
#
# Results:
# None.
method ReferenceFunctions {api} {
set 0 [Const 0]
##### Closure Build:refCountPtr #####
#
# Get a pointer the reference count of a Tcl_Obj reference.
#
# Parameters:
# value - An LLVM value handle holding a STRING/Tcl_Obj
# reference.
# Results:
# A pointer to the reference count, as a LLVM value.
my closure refCountPtr {value {name "refCountPtr"}} {
my getelementptr $value [list $0 $0] $name
}
##### Function tcl.refCount #####
##### Closure Build:refCount #####
#
# Get the reference count of a Tcl_Obj reference.
#
# Parameters:
# objPtr -
# An LLVM value handle holding a STRING/Tcl_Obj
# reference.
# Results:
# The reference count, as a LLVM value.
set f [$m local "tcl.refCount" int<-Tcl_Obj* readonly]
params value:objPtr
build {
nonnull $value
my ret [my load [my refCountPtr $value] "refCount"]
}
my closure refCount {objPtr {resultName "refCount"}} {
my call [$f ref] [list $objPtr] $resultName
}
##### tcl.shared -> shared #####
##### Closure Build:shared #####
#
# Get whether a Tcl_Obj reference is shared.
#
# Parameters:
# objPtr -
# An LLVM value handle holding a STRING/Tcl_Obj
# reference.
# Results:
# The flag, as a boolean (int1) LLVM value.
set f [$m local "tcl.shared" bool<-Tcl_Obj* readonly]
params value:objPtr
build {
nonnull $value
my ret [my gt [my refCount $value] [Const 1] "shared"]
}
my closure shared {objPtr {resultName "shared"}} {
my call [$f ref] [list $objPtr] $resultName
}
##### tcl.addReference #####
#
# Type signature: objPtr:Tcl_Obj* -> void
#
# Increment the reference count of a Tcl_Obj reference.
set f [$m local "tcl.addReference" void<-Tcl_Obj*]
params value:objPtr
build {
nonnull $value
$api Tcl_IncrRefCount $value
my ret
}
##### tcl.dropReference #####
#
# Type signature: objPtr:Tcl_Obj* -> void
#
# Decrement the reference count of a Tcl_Obj reference, and delete it
# if the reference count drops to zero.
set f [$m local "tcl.dropReference" void<-Tcl_Obj*]
params value:objPtr
build {
nonnull $value
$api Tcl_DecrRefCount $value
my ret
}
##### tcl.addMaybeReference #####
#
# Type signature: objPtr:Tcl_Obj*? -> void
#
# Increment the reference count of a Tcl_Obj reference if the
# object is supplied
set f [$m local "tcl.addMaybeReference" void<-Tcl_Obj*?]
params value:maybeObjPtr
build {
my condBr [my maybe $value] $nothing $incr
label incr "action.required"
set value [my unmaybe $value "objPtr"]
$api Tcl_IncrRefCount $value
my ret
label nothing "nothing.to.do"
my ret
}
##### tcl.dropMaybeReference #####
#
# Type signature: objPtr:Tcl_Obj*? -> void
#
# Decrement the reference count of a Maybe containing a Tcl_Obj
# reference, and delete it if the reference count drops to zero.
set f [$m local "tcl.dropMaybeReference" void<-Tcl_Obj*?]
params value:maybeObjPtr
build {
my condBr [my maybe $value] $nothing $decr
label decr "action.required"
set value [my unmaybe $value "objPtr"]
$api Tcl_DecrRefCount $value
my ret
label nothing "nothing.to.do"
my ret
}
##### tcl.unshare #####
#
# Type signature: objPtr:Tcl_Obj* -> Tcl_Obj*
#
# Create and return an unshared version of a Tcl_Obj reference. This
# only duplicates the Tcl_Obj if necessary.
set f [$m local "tcl.unshare" Tcl_Obj*<-Tcl_Obj*]
params value:objPtr
build {
nonnull $value
set refCount [my refCount $value]
my switch [my refCount $value] $b2 \
0 $b0 1 $b1
label b0 "noReference"
my addReference(STRING) $value
my addReference(STRING) $value
my ret $value
label b1 "noDuplicate"
my ret $value
label b2 "duplicated"
set value2 [$api Tcl_DuplicateObj $value]
my addReference(STRING) $value2
my dropReference $value
my ret $value2
}
##### tcl.unshare.copy #####
#
# Type signature: objPtr:Tcl_Obj* -> Tcl_Obj*
#
# Duplicate a Tcl_Obj reference and return it. This *always*
# duplicates.
set f [$m local "tcl.unshare.copy" Tcl_Obj*<-Tcl_Obj* readonly]
params value:objPtr
build {
nonnull $value
set dupe [$api Tcl_DuplicateObj $value]
my addReference(STRING) $dupe
my ret $dupe
}
return
}
# Builder:StringFunctions --
#
# Generate the functions that implement the string-related quadcodes.
# Only called from @apiFunctions method.
#
# Parameters:
# api - The handle of the Tcl API object (currently an instance of the
# Thunk class).
#
# Results:
# None.
method StringFunctions {api} {
set sizeof(Tcl_UniChar) [Const 2]
set sizeof(UTF_BYTES) [Const 8]
set 0 [Const 0]
set 1 [Const 1]
set -1 [Const -1]
set size_t [Type int]; # TODO really size_t, not int
##### Closure Build:printref #####
#
# Type signature: val:STRING -> void
#
# Print a description of the given Tcl_Obj reference. Used for
# debugging reference counts.
set f [$m local writeref void<-int,STRING,char* noinline]
params pr val prefix
build {
nonnull $val
set chan [$api Tcl_GetStdChannel [Const [expr 1<<3]]]
my condBr [my nonnull $prefix] $printPrefix $printRef
label printPrefix "print.prefix"
set str [$api Tcl_NewStringObj $prefix [Const -1]]
$api Tcl_WriteObj $chan $str
$api Tcl_DecrRefCount $str
my br $printRef
label printRef "print.reference"
# Multi-stage print so we still get something useful when memory
# is corrupted.
set str [$api Tcl_ObjPrintf \
[my constString "%d:0x%X"] \
$pr [my castPtr2Int $val int]]
$api Tcl_WriteObj $chan $str
$api Tcl_DecrRefCount $str
set rc [my refCount $val]
set str [$api Tcl_ObjPrintf \
[my constString "(%.30s) => %d\n"] \
[$api Tcl_GetString $val] $rc]
$api Tcl_WriteObj $chan $str
$api Tcl_DecrRefCount $str
my ret
}
set f [$m local writeref? void<-int,STRING?,char*]
params pr val prefix
build {
my condBr [my maybe $val] $done $print
label print:
my Call writeref $pr [my unmaybe $val] $prefix
my ret
label done:
my ret
}
my closure printref {val {prefix ""}} {
if {![info exists ::env(TQC_PRINT_REFERENCE_MANAGEMENT)]} {
return
}
if {[TypeOf $val] eq [Type STRING]} {
set writerFunc writeref
} elseif {[TypeOf $val] eq [Type STRING?]} {
set writerFunc writeref?
} elseif {[GetTypeKind [TypeOf $val]] eq "LLVMStructTypeKind"} {
set idx -1
foreach t [GetStructElementTypes [TypeOf $val]] {
incr idx
if {$t eq [Type STRING] || $t eq [Type STRING?]
|| [GetTypeKind $t] eq "LLVMStructTypeKind"} {
my printref [my extract $val $idx] $prefix
}
}
return
} else {
my Warn "printref incomplete for \"%s\"" \
[PrintValueToString $val]
return
}
if {$prefix ne ""} {
set prefix [my constString $prefix]
} else {
set prefix [my null char*]
}
variable prcount
set pr [Const [incr prcount]]
# set name [format %.30s... [PrintValueToString $val]]
my Call $writerFunc $pr $val $prefix
return
}
##### Closure Build:memcpy #####
#
# Type signature: target:[?]* * source:[?]* * length:int[?] -> void
#
# Copy memory of size 'length' from 'source' to 'target'.
my closure memcpy {target source length} {
set vt [Type void*]
set memcpy [$m intrinsic memcpy $vt $vt [TypeOf $length]]
if {[TypeOf $target] ne $vt} {
set target [my cast(ptr) $target void]
}
if {[TypeOf $source] ne $vt} {
set source [my cast(ptr) $source void]
}
my Call memcpy $target $source $length \
[Const 0] [Const false bool]
return
}
##### Closure Build:bzero #####
#
# Type signature: memoryBlock:[?]* * length:int[?] -> void
#
# Zeroes memory of size 'length' starting at 'memoryBlock'. An
# optional alignment may be given (as a simple Tcl integer); it
# defaults to the platform alignment size, which is ideal for zeroing
# normal structures on modern architectures.
my closure bzero {target length {alignment -1}} {
if {$alignment < 0} {
set alignment $::tcl_platform(wordSize)
}
set vt [Type void*]
set memset [$m intrinsic memset $vt [TypeOf $length]]
if {[TypeOf $target] ne $vt} {
set target [my cast(ptr) $target void]
}
my Call memset $target [Const 0 int8] $length \
[Const $alignment] [Const false bool]
return
}
##### Closure Build:memcmp #####
#
# Type signature: a:[?]* * b:[?]* * length:int[?] -> int
#
# Compare memory of size 'length' between 'a' and 'b'.
set memcmp [$m function.extern memcmp \
[Type func{int<-void*,void*,$size_t}] readonly]
my closure memcmp {bytes1 bytes2 length {name "cmp"}} {
set vt [Type void*]
if {[TypeOf $bytes1] ne $vt} {
set bytes1 [my cast(ptr) $bytes1 void]
}
if {[TypeOf $bytes2] ne $vt} {
set bytes2 [my cast(ptr) $bytes2 void]
}
if {[TypeOf $length] ne [Type $size_t]} {
set length [my castInt2Int $length $size_t]
}
my call $memcmp [list $bytes1 $bytes2 $length] $name
}
my StringInspectionFunctions $api
my StringWritingFunctions $api
my StringComparisonFunctions $api
return
}
# Builder:StringInspectionFunctions --
#
# Generate the functions that implement the read-only string operations.
# Only called from StringFunctions method.
#
# Parameters:
# api - The handle of the Tcl API object (currently an instance of the
# Thunk class).
#
# Results:
# None.
method StringInspectionFunctions {api} {
upvar 1 sizeof sizeof 0 0 1 1
##### Function tcl.strlen #####
#
# Type signature: objPtr:STRING -> INT
#
# Quadcode implementation ('strlen')
#
# Returns the length of the string in *characters*.
set f [$m local "tcl.strlen" INT<-STRING]
params value:objPtr
build {
nonnull $value
set refCount [my refCountPtr $value]
set before [my load $refCount "before"]
set result [my packInt32 [$api Tcl_GetCharLength $value]]
set after [my load $refCount "after"]
my assume [my eq $before $after]
my ret $result
}
##### Function tcl.isPureByteArray #####
##### Closure Build:isByteArray #####
#
# Type signature: objPtr:STRING -> int1
#
# Test if a STRING is actually a true byte array, that it can be
# processed as bytes and not as unicode characters.
set f [$m local "tcl.isPureByteArray" int1<-STRING readonly]
params objPtr
build {
nonnull $objPtr
set baType [$api tclByteArrayType]
set typePtr [my dereference $objPtr 0 Tcl_Obj.typePtr]
my condBr [my eq $baType $typePtr] $puretest $notBA
label puretest:
my condBr [my nonnull [my dereference $objPtr 0 Tcl_Obj.bytes]] \
$notBA $isBA
label isBA:
my ret [Const true bool]
label notBA:
my ret [Const false bool]
}
my closure isByteArray {STRING {name ""}} {
my call ${tcl.isPureByteArray} [list $STRING] $name
}
##### Function tcl.isUnicodeString #####
##### Closure Build:isUnicodeString #####
#
# Type signature: objPtr:STRING -> int1
#
# Test if a STRING is stored internally as a sequence of Tcl_UniChar
# (instead of as a sequence of Unicode characters encoded as UTF-8).
set f [$m local "tcl.isUnicodeString" int1<-STRING readonly]
params objPtr
build {
nonnull $objPtr
set strType [$api tclStringType]
set type [my dereference $objPtr 0 Tcl_Obj.typePtr]
my ret [my eq $type $strType]
}
my closure isUnicodeString {STRING {name ""}} {
my call ${tcl.isUnicodeString} [list $STRING] $name
}
##### Function tcl.impl.getDouble #####
##### MAPPED CALL TO METHOD: Build:GetDouble #####
#
# Type signature: valueObj:STRING -> int * int8[]
#
# Gets the (pseudo-)UTF-8 version of a string. Wrapper around Tcl API
# to ensure that scope lifetime gets better understood.
set f [$m local "tcl.impl.getDouble" struct{int1,double}<-STRING]
my closure GetDouble {valueObj} {
my call ${tcl.impl.getDouble} [list $valueObj] "result"
}
params valueObj
build {
nonnull $valueObj
set dblVar [my alloc double "dblPtr"]
set code [$api Tcl_GetDoubleFromObj {} $valueObj $dblVar]
set res [my undef struct{int1,double}]
set res [my insert $res [my eq $code [Const 0]] 0]
set res [my insert $res [my load $dblVar "dbl"] 1]
my ret $res
}
unset -nocomplain valueObj
##### Function tcl.impl.getWide #####
##### MAPPED CALL TO METHOD: Build:GetWide #####
#
# Type signature: valueObj:STRING -> int * int64
#
# Gets an int64 from a Tcl string. Wrapper around Tcl API to ensure
# that scope lifetime gets better understood.
set f [$m local "tcl.impl.getWide" struct{int1,int64}<-STRING]
my closure GetWide {valueObj} {
my call ${tcl.impl.getWide} [list $valueObj] "result"
}
params valueObj
build {
nonnull $valueObj
set intVar [my alloc int64 "intPtr"]
set code [$api Tcl_GetWideIntFromObj {} $valueObj $intVar]
set res [my undef struct{int1,int64}]
set res [my insert $res [my eq $code [Const 0]] 0]
set res [my insert $res [my load $intVar "int"] 1 "result"]
my ret $res
}
unset -nocomplain valueObj
##### Function tcl.impl.getString #####
##### MAPPED CALL TO METHOD: Build:GetString #####
#
# Type signature: stringObj:STRING -> int * int8[]
#
# Gets the (pseudo-)UTF-8 version of a string. Wrapper around Tcl API
# to ensure that scope lifetime gets better understood.
set f [$m local "tcl.impl.getString" struct{int,int8*}<-STRING readonly]
my closure GetString {string name} {
set data [my Call tcl.impl.getString $string]
set len [my extract $data 0 "$name.length"]
set chars [my extract $data 1 "$name.string"]
return [list $len $chars]
}
params stringObj
build {
nonnull $stringObj
set var [my alloc int "lengthPtr"]
set chars [$api Tcl_GetStringFromObj $stringObj $var]
set res [my undef struct{int,int8*}]
set res [my insert $res [my load $var "length"] 0]
set res [my insert $res $chars 1 "result"]
my ret $res
}
##### Function tcl.impl.getUnicode #####
##### MAPPED CALL TO METHOD: Build:GetUnicode #####
#
# Type signature: stringObj:STRING -> int * int16[]
#
# Gets the unicode (UCS-2?) version of a string. Wrapper around Tcl
# API to ensure that scope lifetime gets better understood.
set f [$m local "tcl.impl.getUnicode" struct{int,int16*}<-STRING readonly]
my closure GetUnicode {string name} {
set data [my Call tcl.impl.getUnicode $string]
set len [my extract $data 0 "$name.length"]
set unichars [my extract $data 1 "$name.string"]
return [list $len $unichars]
}
params stringObj
build {
nonnull $stringObj
set var [my alloc int "lengthPtr"]
set chars [$api Tcl_GetUnicodeFromObj $stringObj $var]
set res [my undef struct{int,int16*}]
set res [my insert $res [my load $var "length"] 0]
set res [my insert $res $chars 1 "result"]
my ret $res
}
##### Function tcl.impl.getBytes #####
##### MAPPED CALL TO METHOD: Build:GetBytes #####
#
# Type signature: stringObj:STRING -> int * int8[]
#
# Gets the byte array version of a string. Wrapper around Tcl API to
# ensure that scope lifetime gets better understood.
set f [$m local "tcl.impl.getBytes" struct{int,int8*}<-STRING readonly]
my closure GetBytes {string name} {
set data [my Call tcl.impl.getBytes $string]
set len [my extract $data 0 "$name.length"]
set bytes [my extract $data 1 "$name.bytes"]
return [list $len $bytes]
}
params stringObj
build {
nonnull $stringObj
set var [my alloc int "lengthPtr"]
set chars [$api Tcl_GetByteArrayFromObj $stringObj $var]
set res [my undef struct{int,int8*}]
set res [my insert $res [my load $var "length"] 0]
set res [my insert $res $chars 1 "result"]
my ret $res
}
##### Function tcl.strfind.fwd #####
#
# Type signature: needlePtr:STRING * haystackPtr:STRING -> INT
#
# Quadcode implementation ('strfind')
#
# Returns the index where the first instance of the string haystackPtr
# is found in the string needlePtr, or -1 if the string is not found.
set f [$m local "tcl.strfind.fwd" INT<-STRING,STRING]
params needlePtr haystackPtr
unset -nocomplain loop
build {
nonnull $needlePtr $haystackPtr
lassign [my GetUnicode $haystackPtr haystack] len1 haystack
lassign [my GetUnicode $needlePtr needle] len2 needle
my condBr [my gt $len2 $0] $checklen $noMatch
label checklen:
my condBr [my le $len2 $len1] $loop(init) $noMatch
label loop(init) "doSearch.init"
set end [my getelementptr $haystack \
[list [my add [my sub $len1 $len2] $1]] "end"]
set needle_0 [my load $needle "needle.0"]
set ptr [my alloc [TypeOf $haystack] "ptr"]
my store $haystack $ptr
my br $loop(check)
label loop(check) "doSearch.check"
my condBr [my lt [my load $ptr] $end] $loop(1) $noMatch
label loop(next) "doSearch.next"
my store [my gep [my load $ptr] 1] $ptr
my br $loop(check)
label loop(1) "doSearch.loop1"
set p [my load $ptr "p"]
my condBr [my eq [my load $p] $needle_0] $loop(2) $loop(next)
label loop(2) "doSearch.loop2"
set testResult [my memcmp $needle $p \
[my mult $sizeof(Tcl_UniChar) $len2]]
my condBr [my eq $testResult $0] $found $loop(next)
label found:
my ret [my packInt32 [my cast(int) [my diff $p $haystack]]]
label noMatch:
my ret [my int -1]
}
##### Function tcl.strfind.rev #####
#
# Type signature: needlePtr:STRING * haystackPtr:STRING -> INT
#
# Quadcode implementation ('strrfind')
#
# Returns the index where the last instance of the string haystackPtr
# is found in the string needlePtr, or -1 if the string is not found.
set f [$m local "tcl.strfind.rev" INT<-STRING,STRING]
params needlePtr haystackPtr
unset -nocomplain loop
build {
nonnull $needlePtr $haystackPtr
lassign [my GetUnicode $haystackPtr haystack] len1 haystack
lassign [my GetUnicode $needlePtr needle] len2 needle
my condBr [my gt $len2 $0] $checklen $noMatch
label checklen:
my condBr [my le $len2 $len1] $loop(init) $noMatch
label loop(init) "doSearch.init"
set needle_0 [my load $needle "needle.0"]
set ptr [my alloc [TypeOf $haystack] "ptr"]
my store [my getelementptr $haystack [list [my sub $len1 $len2]]]\
$ptr
my br $loop(check)
label loop(check) "doSearch.check"
my condBr [my ge [my load $ptr] $haystack] $loop(1) $noMatch
label loop(next) "doSearch.next"
my store [my gep [my load $ptr] -1] $ptr
my br $loop(check)
label loop(1) "doSearch.loop1"
set p [my load $ptr "p"]
my condBr [my eq [my load $p] $needle_0] $loop(2) $loop(next)
label loop(2) "doSearch.loop2"
set testResult [my memcmp $needle $p \
[my mult $sizeof(Tcl_UniChar) $len2]]
my condBr [my eq $testResult $0] $found $loop(next)
label found:
my ret [my packInt32 [my cast(int) [my diff $p $haystack]]]
label noMatch:
my ret [my int -1]
}
##### Function tcl.impl.trimleft #####
# Replacement for non-exposed TclTrimLeft
#
# Type signature: bytes:char* * numBytes:int32 * trim:char* *
# numTrim:int32 -> int32
#
# Part of quadcode implementation ('strtrim')
#
# Returns the number of bytes to be trimmed from the beginning of the
# string 'bytes' (length 'numBytes'), where the characters to be
# trimmed are in the string 'trim' (length 'numTrim'). Works on UTF-8.
set f [$m local "tcl.impl.trimleft" int<-char*,int,char*,int readonly]
params bytes numBytes trim numTrim
build {
nonnull $bytes $trim
set chVar [my alloc int16]
set pLoop [my uniqueUndef char* "p"]
set nbLoop [my uniqueUndef int "nb"]
my condBr [my eq $numBytes $0] $ret0 $checkTrim
label checkTrim:
my condBr [my eq $numTrim $0] $ret0 $outerLoop
label ret0:
my ret $0
label outerLoop:
set sources [list $checkTrim $nextOuter]
set p [my phi [list $bytes $pLoop] $sources "p"]
set numBytes [my phi [list $numBytes $nbLoop] $sources "numBytes"]
set pInc [$api Tcl_UtfToUniChar $p $chVar]
SetValueName $pInc "pInc"
set ch1 [my load $chVar "ch1"]
set qLoop [my uniqueUndef char* "q"]
set blLoop [my uniqueUndef int "bl"]
my br $innerLoop
label innerLoop:
set sources [list $outerLoop $nextInner]
set q [my phi [list $trim $qLoop] $sources "q"]
set bytesLeft [my phi [list $numTrim $blLoop] $sources "bytesLeft"]
set qInc [$api Tcl_UtfToUniChar $q $chVar]
SetValueName $qInc "qInc"
set ch2 [my load $chVar "ch2"]
my condBr [my eq $ch1 $ch2] $doneInner $nextInner
label nextInner:
ReplaceAllUsesWith $qLoop [my getelementptr $q [list $qInc] "q"]
ReplaceAllUsesWith $blLoop \
[set bytesLeft2 [my sub $bytesLeft $qInc "bytesLeft"]]
my condBr [my gt $bytesLeft2 $0] $innerLoop $doneInner
label doneInner:
set sources [list $innerLoop $nextInner]
set bytesLeft [my phi [list $bytesLeft $bytesLeft2] $sources "bytesLeft"]
my condBr [my le $bytesLeft $0] $doneOuter $nextOuter
label nextOuter:
ReplaceAllUsesWith $pLoop \
[set p2 [my getelementptr $p [list $pInc] "p"]]
ReplaceAllUsesWith $nbLoop \
[set numBytes [my sub $numBytes $pInc "numBytes"]]
my condBr [my gt $numBytes $0] $outerLoop $doneOuter
label doneOuter:
set p [my phi [list $p $p2] [list $doneInner $nextOuter] "p"]
my ret [my cast(int) [my diff $p $bytes]]
}
##### Function tcl.impl.trimright #####
# Replacement for non-exposed TclTrimRight
#
# Type signature: bytes:char* * numBytes:int32 * trim:char* *
# numTrim:int32 -> int32
#
# Part of quadcode implementation ('strtrim')
#
# Returns the number of bytes to be trimmed from the end of the string
# 'bytes' (length 'numBytes'), where the characters to be trimmed are
# in the string 'trim' (length 'numTrim'). Works on UTF-8.
set f [$m local "tcl.impl.trimright" int<-char*,int,char*,int readonly]
params bytes numBytes trim numTrim
build {
nonnull $bytes $trim
set chVar [my alloc int16]
set pLoop [my uniqueUndef char* "p"]
set nbLoop [my uniqueUndef int "nb"]
set p [my getelementptr $bytes [list $numBytes] "p"]
my condBr [my eq $numBytes $0] $ret0 $checkTrim
label checkTrim:
my condBr [my eq $numTrim $0] $ret0 $outerLoop
label ret0:
my ret $0
label outerLoop:
set sources [list $checkTrim $nextOuter]
set p [my phi [list $p $pLoop] $sources "p"]
set numBytes [my phi [list $numBytes $nbLoop] $sources "numBytes"]
set p [$api Tcl_UtfPrev $p $bytes]
SetValueName $p "p"
set pInc [$api Tcl_UtfToUniChar $p $chVar]
SetValueName $pInc "pInc"
set ch1 [my load $chVar "ch1"]
set qLoop [my uniqueUndef char* "q"]
set blLoop [my uniqueUndef int "bl"]
my br $innerLoop
label innerLoop:
set sources [list $outerLoop $nextInner]
set q [my phi [list $trim $qLoop] $sources "q"]
set bytesLeft [my phi [list $numTrim $blLoop] $sources "bytesLeft"]
set qInc [$api Tcl_UtfToUniChar $q $chVar]
SetValueName $qInc "qInc"
set ch2 [my load $chVar "ch2"]
my condBr [my eq $ch1 $ch2] $doneInner $nextInner
label doneInner:
my condBr [my le $bytesLeft $0] $fixP $nextOuter
label nextInner:
ReplaceAllUsesWith $qLoop [my getelementptr $q [list $qInc] "q"]
ReplaceAllUsesWith $blLoop \
[set bytesLeft [my sub $bytesLeft $qInc "bytesLeft"]]
my condBr [my gt $bytesLeft $0] $innerLoop $fixP
label nextOuter:
ReplaceAllUsesWith $pLoop $p
ReplaceAllUsesWith $nbLoop $numBytes
my condBr [my gt $p $bytes] $outerLoop $doneOuter
label fixP:
set p0 [my phi [list $p $p] [list $doneInner $nextInner] "p"]
set p2 [my getelementptr $p0 [list $pInc] "p"]
my br $doneOuter
label doneOuter:
set p [my phi [list $p $p2] [list $nextOuter $fixP] "p"]
my ret [my sub $numBytes [my cast(int) [my diff $p $bytes]]]
}
##### Function tcl.impl.isAscii #####
# Replacement for non-exposed UniCharIsAscii
#
# Type signature: ch:int16 -> int1
#
# Part of quadcode implementation ('strclass')
#
# Returns whether the character 'ch' is in the ASCII range.
set f [$m local "tcl.impl.isAscii" bool<-int16 readnone]
params ch
build {
my ret [my and [my ge $ch [Const 0 int16]] \
[my lt $ch [Const 0x80 int16]]]
}
##### Function tcl.impl.isXdigit #####
# Replacement for non-exposed UniCharIsXdigit
#
# Type signature: ch:int16 -> int1
#
# Part of quadcode implementation ('strclass')
#
# Returns whether the character 'ch' is a hex digit.
set f [$m local "tcl.impl.isXdigit" bool<-int16 readnone]
params ch
build {
my switch $ch $not \
0x30 $ok 0x31 $ok 0x32 $ok 0x33 $ok 0x34 $ok \
0x35 $ok 0x36 $ok 0x37 $ok 0x38 $ok 0x39 $ok \
0x41 $ok 0x42 $ok 0x43 $ok 0x44 $ok 0x45 $ok 0x46 $ok \
0x61 $ok 0x62 $ok 0x63 $ok 0x64 $ok 0x65 $ok 0x66 $ok
label ok:
my ret [Const true bool]
label not:
my ret [Const false bool]
}
##### Function tcl.strclass #####
#
# Type signature: objPtr:STRING * class:int32 -> ZEROONE
#
# Quadcode implementation ('strclass')
#
# Returns whether all the characters in the string 'objPtr' are in the
# character class given by 'class' (enumeration encoded as int32).
set f [$m local "tcl.strclass" ZEROONE<-STRING,int]
params objPtr class
build {
nonnull $objPtr
lassign [my GetUnicode $objPtr obj] length string
set p0 [my uniqueUndef int16* "p"]
set p1 [my uniqueUndef int16* "p"]
set p2 [my uniqueUndef int16* "p"]
set p3 [my uniqueUndef int16* "p"]
set p4 [my uniqueUndef int16* "p"]
set p5 [my uniqueUndef int16* "p"]
set p6 [my uniqueUndef int16* "p"]
set p7 [my uniqueUndef int16* "p"]
set p8 [my uniqueUndef int16* "p"]
set p9 [my uniqueUndef int16* "p"]
set p10 [my uniqueUndef int16* "p"]
set p11 [my uniqueUndef int16* "p"]
set p12 [my uniqueUndef int16* "p"]
my condBr [my gt $length $0] $test $match
label test:
set end [my getelementptr $string [list $length]]
my switch $class $xdigit \
0 $alnum 1 $alpha 2 $ascii 3 $control \
4 $digit 5 $graph 6 $lower 7 $print \
8 $punct 9 $space 10 $upper 11 $word
set n [list $1]
label alnum:
set p [my phi [list $string $p0] [list $test $alnumNext] "p"]
my condBr [my neq [$api Tcl_UniCharIsAlnum [my load $p]] $0] \
$alnumNext $fail
label alnumNext "alnum.next"
ReplaceAllUsesWith $p0 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $alnum $match
label alpha:
set p [my phi [list $string $p1] [list $test $alphaNext] "p"]
my condBr [my neq [$api Tcl_UniCharIsAlpha [my load $p]] $0] \
$alphaNext $fail
label alphaNext "alpha.next"
ReplaceAllUsesWith $p1 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $alpha $match
label ascii:
set p [my phi [list $string $p2] [list $test $asciiNext] "p"]
my condBr [my Call tcl.impl.isAscii [my load $p]] \
$asciiNext $fail
label asciiNext "ascii.next"
ReplaceAllUsesWith $p2 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $ascii $match
label control:
set p [my phi [list $string $p3] [list $test $controlNext] "p"]
my condBr [my neq [$api Tcl_UniCharIsControl [my load $p]] $0] \
$controlNext $fail
label controlNext "control.next"
ReplaceAllUsesWith $p3 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $control $match
label digit:
set p [my phi [list $string $p4] [list $test $digitNext] "p"]
my condBr [my neq [$api Tcl_UniCharIsDigit [my load $p]] $0] \
$digitNext $fail
label digitNext "digit.next"
ReplaceAllUsesWith $p4 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $digit $match
label graph:
set p [my phi [list $string $p5] [list $test $graphNext] "p"]
my condBr [my neq [$api Tcl_UniCharIsGraph [my load $p]] $0] \
$graphNext $fail
label graphNext "graph.next"
ReplaceAllUsesWith $p5 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $graph $match
label lower:
set p [my phi [list $string $p6] [list $test $lowerNext] "p"]
my condBr [my neq [$api Tcl_UniCharIsLower [my load $p]] $0] \
$lowerNext $fail
label lowerNext "lower.next"
ReplaceAllUsesWith $p6 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $lower $match
label print:
set p [my phi [list $string $p7] [list $test $printNext] "p"]
my condBr [my neq [$api Tcl_UniCharIsPrint [my load $p]] $0] \
$printNext $fail
label printNext "print.next"
ReplaceAllUsesWith $p7 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $print $match
label punct:
set p [my phi [list $string $p8] [list $test $punctNext] "p"]
my condBr [my neq [$api Tcl_UniCharIsPunct [my load $p]] $0] \
$punctNext $fail
label punctNext "punct.next"
ReplaceAllUsesWith $p8 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $punct $match
label space:
set p [my phi [list $string $p9] [list $test $spaceNext] "p"]
my condBr [my neq [$api Tcl_UniCharIsSpace [my load $p]] $0] \
$spaceNext $fail
label spaceNext "space.next"
ReplaceAllUsesWith $p9 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $space $match
label upper:
set p [my phi [list $string $p10] [list $test $upperNext] "p"]
my condBr [my neq [$api Tcl_UniCharIsUpper [my load $p]] $0] \
$upperNext $fail
label upperNext "upper.next"
ReplaceAllUsesWith $p10 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $upper $match
label word:
set p [my phi [list $string $p11] [list $test $wordNext] "p"]
my condBr [my neq [$api Tcl_UniCharIsWordChar [my load $p]] $0] \
$wordNext $fail
label wordNext "word.next"
ReplaceAllUsesWith $p11 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $word $match
label xdigit:
set p [my phi [list $string $p12] [list $test $xdigitNext] "p"]
my condBr [my Call tcl.impl.isXdigit [my load $p]] \
$xdigitNext $fail
label xdigitNext "xdigit.next"
ReplaceAllUsesWith $p12 [set p [my getelementptr $p $n "p"]]
my condBr [my lt $p $end] $xdigit $match
label match:
my ret [Const true bool]
label fail:
my ret [Const false bool]
}
##### Function tcl.impl.getIndex #####
##### Closure Build:GetIndex #####
#
# Type signature: interp:Tcl_Interp* * objPtr:Tcl_Obj* * end:int
# -> int1 * int
#
# Converts an index string into an offset into something (i.e., a
# string or list). Returns a tuple of whether the conversion succeeded
# (a boolean) and the index.
set f [$m local "tcl.impl.getIndex" struct{bool,int}<-Tcl_Interp*,Tcl_Obj*,int readonly]
unset -nocomplain objPtr end
my closure GetIndex {interp objPtr end {indexVar dummy}} {
upvar 1 $indexVar index
if {$interp eq ""} {
set interp [my null Tcl_Interp*]
}
set res [my Call tcl.impl.getIndex $interp $objPtr $end]
set index [my extract $res 1 "getIndex.index"]
return [my extract $res 0 "getIndex.result"]
}
params interp objPtr end
build {
noalias $interp $objPtr
nonnull $objPtr
set ret [my undef struct{bool,int}]
my condBr [my eq [my dereference $objPtr 0 Tcl_Obj.typePtr] \
[$api tclIntType]] \
$direct $call
label direct:
set repPtr [my gep $objPtr 0 Tcl_Obj.internalRep]
set retD [my insert $ret [Const true bool] 0]
my ret [my insert $retD \
[my load [my cast(ptr) $repPtr int] "longValue"] 1]
label call:
set idxPtr [my alloc int "index"]
set code [$api TclGetIntForIndex $interp $objPtr $end $idxPtr]
set retC [my insert $ret [my eq $code $0] 0]
my ret [my insert $retC [my load $idxPtr] 1]
}
}
# Builder:StringWritingFunctions --
#
# Generate the functions that implement the string-creating operators.
# Only called from StringFunctions method.
#
# Parameters:
# api - The handle of the Tcl API object (currently an instance of the
# Thunk class).
#
# Results:
# None.
# Note that each of these (that returns a string at all) *must* increment
# the reference count of the values it returns; the general engine assumes
# that this is necessarily so.
method StringWritingFunctions {api} {
upvar 1 sizeof sizeof 0 0 1 1 -1 -1
##### Function tcl.setFromAny #####
##### Closure Build:setFromAny #####
#
# Type signature: typePtr:Tcl_ObjType* * interp:Tcl_Interp*
# * objPtr:STRING -> int
#
# Call the given type's setFromAnyProc on the given object.
set f [$m local "tcl.setFromAny" int<-Tcl_ObjType*,Tcl_Interp*,STRING]
params typePtr interp objPtr
build {
noalias $typePtr $interp $objPtr
nonnull $typePtr $objPtr
set func [my dereference $typePtr 0 Tcl_ObjType.setFromAnyProc]
set func [my cast(ptr) $func func{int<-Tcl_Interp*,Tcl_Obj*} "setFromAny"]
set code [my Call $func $interp $objPtr]
SetValueName $code "code"
AddCallAttribute $code 1 nocapture
AddCallAttribute $code 2 nocapture
my ret $code
}
my closure setFromAny {TYPE INTERP VALUE {name "code"}} {
my call ${tcl.setFromAny} [list $TYPE $INTERP $VALUE] $name
}
##### Functions obj.dedup, obj.cleanup #####
##### Closure: Build:Dedup #####
#
# Type signatures: obj:STRING -> {STRING,bool}
# objdupe:{STRING,bool} -> void
#
# Helpers for the dictionary updating functions that reduce the amount
# of explicit branch management in the code by factoring out common
# patterns of reference handling.
set f [$m local "obj.dedup" struct{STRING,int1}<-STRING]
params obj
build {
set duped [my shared $obj]
SetValueName $duped "duped"
set res [my insert [my undef struct{STRING,int1}] $duped 1]
my condBr $duped $duplicated $unshared
label duplicated:
set dupe [$api Tcl_DuplicateObj $obj]
SetValueName $dupe "duplicateObj"
my ret [my insert $res $dupe 0]
label unshared:
my ret [my insert $res $obj 0]
}
my closure Dedup {varName} {
upvar 1 $varName var
set token [my Call obj.dedup $var]
set var [my extract $token 0 [GetValueName $var]]
return $token
}
set f [$m local "obj.cleanup" void<-struct{STRING,int1}]
params objdupe
build {
my condBr [my extract $objdupe 1] $duplicated $unshared
label duplicated:
my dropReference [my extract $objdupe 0]
my ret
label unshared:
my ret
}
##### Function tcl.append.string #####
#
# Type signature: bufferObjPtr:STRING * valueObjPtr:STRING -> void
#
# Part of quadcode implementation ('strcat')
#
# Appends the string in 'valueObjPtr' to the string in 'bufferObjPtr'.
# The buffer must be unshared.
set f [$m local "tcl.append.string" void<-STRING,STRING]
params buffer:bufferObjPtr value:valueObjPtr
build {
noalias $buffer $value
nonnull $buffer $value
set refCountBuf [my refCountPtr $buffer]
set beforeBuf [my load $refCountBuf "before.buf"]
my assume [my le $beforeBuf $1]
set refCountVal [my refCountPtr $value]
set beforeVal [my load $refCountVal "before.val"]
$api Tcl_AppendObjToObj $buffer $value
set afterBuf [my load $refCountBuf "after.buf"]
my assume [my eq $beforeBuf $afterBuf]
set afterVal [my load $refCountVal "after.val"]
my assume [my eq $beforeVal $afterVal]
my ret
}
##### Function tcl.stridx #####
#
# Type signature: objPtr:STRING * indexInt:INT -> STRING
#
# Quadcode implementation ('stridx')
#
# Returns the character (as a single character string) at index
# 'indexInt' of string 'objPtr', or the empty string if the index does
# not refer to a position inside the string.
set f [$m local "tcl.stridx" STRING<-STRING,INT]
params str:objPtr idxInt:indexInt
build {
nonnull $str
set idx [my cast(int) [my getInt64 $idxInt] "index"]
my condBr [my lt $idx $0] $empty $testTooLong
label empty:
set emptyResult [$api Tcl_NewObj]
my br $done
label testTooLong:
set len [$api Tcl_GetCharLength $str]
my condBr [my ge $idx $len] $empty $isPure
label isPure:
my condBr [my isByteArray $str] $baIdx $nexttest
label nexttest:
my condBr [my nonnull [my dereference $str 0 Tcl_Obj.bytes]] \
$nexttest2 $strIdx
label nexttest2:
my condBr [my eq $len [my dereference $str 0 Tcl_Obj.length]] \
$byteIndex $strIdx
label baIdx "byteArrayIndexing"
set bytes [$api Tcl_GetByteArray $str]
set bytePtr [my getelementptr $bytes [list $idx]]
set byteResult [$api Tcl_NewByteArrayObj $bytePtr $1]
my br $done
label byteIndex "fastStringIndexing"
set bytes [my dereference $str 0 Tcl_Obj.bytes]
set bytePtr [my getelementptr $bytes [list $idx]]
set asciiResult [$api Tcl_NewStringObj $bytePtr $1]
my br $done
label strIdx "slowStringIndexing"
set ch [my cast(uint) [$api Tcl_GetUniChar $str $idx] "ch"]
set buf [my arrayAlloc char $sizeof(UTF_BYTES) "buf"]
set len [$api Tcl_UniCharToUtf $ch $buf]
set unicodeResult [$api Tcl_NewStringObj $buf $len]
my br $done
label done:
set result [my phi \
[list $emptyResult $byteResult $asciiResult $unicodeResult] \
[list $empty $baIdx $byteIndex $strIdx] "result"]
my addReference(STRING) $result
my ret $result
}
##### Function tcl.stridx.idx #####
#
# Type signature: objPtr:STRING * index:STRING * ecvar:int* -> STRING?
#
# Quadcode implementation ('stridx')
#
# Returns the character (as a single character string) at index
# 'indexInt' of string 'objPtr', or the empty string if the index does
# not refer to a position inside the string.
set f [$m local "tcl.stridx.idx" STRING?<-STRING,STRING,int*]
params str:objPtr idx:index ecvar
build {
noalias $ecvar
nonnull $str $idx $ecvar
set interp [$api tclInterp]
set len [$api Tcl_GetCharLength $str]
set end [my sub $len $1 "end"]
my condBr [my GetIndex $interp $idx $end idx] $testBefore $failed
label testBefore:
my condBr [my lt $idx $0] $empty $testTooLong
label empty:
set emptyResult [$api Tcl_NewObj]
my br $done
label testTooLong:
my condBr [my ge $idx $len] $empty $isPure
label isPure:
my condBr [my isByteArray $str] $baIdx $nexttest
label nexttest:
my condBr [my nonnull [my dereference $str 0 Tcl_Obj.bytes]] \
$nexttest2 $strIdx
label nexttest2:
my condBr [my eq $len [my dereference $str 0 Tcl_Obj.length]] \
$byteIndex $strIdx
label baIdx "byteArrayIndexing"
set bytes [$api Tcl_GetByteArray $str]
set bytePtr [my getelementptr $bytes [list $idx]]
set byteResult [$api Tcl_NewByteArrayObj $bytePtr $1]
my br $done
label byteIndex "fastStringIndexing"
set bytes [my dereference $str 0 Tcl_Obj.bytes]
set bytePtr [my getelementptr $bytes [list $idx]]
set asciiResult [$api Tcl_NewStringObj $bytePtr $1]
my br $done
label strIdx "slowStringIndexing"
set ch [my cast(uint) [$api Tcl_GetUniChar $str $idx] "ch"]
set buf [my arrayAlloc char $sizeof(UTF_BYTES) "buf"]
set len [$api Tcl_UniCharToUtf $ch $buf]
set unicodeResult [$api Tcl_NewStringObj $buf $len]
my br $done
label done:
set result [my phi \
[list $emptyResult $byteResult $asciiResult $unicodeResult] \
[list $empty $baIdx $byteIndex $strIdx] "result"]
my addReference(STRING) $result
my ret [my just $result]
label failed:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.strrange #####
#
# Type signature: objPtr:STRING * fromInt:INT * toInt:INT -> STRING
#
# Quadcode implementation ('strrange')
#
# Returns the string that is the substring of string 'objPtr' between
# indices 'fromInt' and 'toInt' (which are both internally clamped to
# the bounds of the string), or the empty string if 'fromInt' does not
# precede 'toInt'.
set f [$m local "tcl.strrange" STRING<-STRING,INT,INT]
params str:objPtr from to
build {
nonnull $str
set from [my max $0 [my cast(int) [my getInt64 $from]] "from"]
set len [my sub [$api Tcl_GetCharLength $str] $1]
set to [my min $len [my cast(int) [my getInt64 $to]] "to"]
my condBr [my ge $to $from] $realSubstring $empty
label empty:
set value1 [$api Tcl_NewObj]
my br $finish
label realSubstring:
set value2 [$api Tcl_GetRange $str $from $to]
my br $finish
label finish:
set result [my phi [list $value1 $value2] \
[list $empty $realSubstring] "result"]
my addReference(STRING) $result
my ret $result
}
##### Function tcl.strrange.idx #####
#
# Type signature: objPtr:STRING * fromIdx:STRING * toIdx:STRING
# * ecvar:int* -> STRING?
#
# Quadcode implementation ('strrange')
#
# Returns the string that is the substring of string 'objPtr' between
# indices 'fromIdx' and 'toIdx' (which are to be decoded as indices),
# or the empty string if 'fromIdx' does not precede 'toIdx'.
set f [$m local "tcl.strrange.idx" STRING?<-STRING,STRING,STRING,int*]
params str:objPtr fromIdx toIdx ecvar
build {
noalias $ecvar
nonnull $str $fromIdx $toIdx $ecvar
set interp [$api tclInterp]
set len [$api Tcl_GetCharLength $str]
set end [my sub $len $1 "end"]
my condBr [my GetIndex $interp $fromIdx $end from] \
$getTo $failed
label getTo:
my condBr [my GetIndex $interp $toIdx $end to] \
$rangeCheck $failed
label rangeCheck:
set from [my max $0 $from "fromIdx"]
set to [my min [my sub $len $1] $to "toIdx"]
my condBr [my ge $to $from] $realSubstring $empty
label empty:
set value1 [$api Tcl_NewObj]
my br $finish
label realSubstring:
set value2 [$api Tcl_GetRange $str $from $to]
my br $finish
label finish:
set result [my phi [list $value1 $value2] \
[list $empty $realSubstring] "result"]
my addReference(STRING) $result
my ret [my just $result]
label failed:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.strreplace #####
#
# Type signature: objPtr:STRING * fromInt:INT * toInt:INT
# * substringPtr:STRING -> STRING
#
# Quadcode implementation ('strreplace')
#
# Returns the string that has the substring of string 'objPtr' between
# indices 'fromInt' and 'toInt' (which are both internally clamped to
# the bounds of the string) replaced with the string 'substringPtr'.
set f [$m local "tcl.strreplace" STRING<-STRING,INT,INT,STRING]
params str:stringPtr fromInt toInt substr:substringPtr
build {
nonnull $str $substr
set from [my max $0 [my getInt32 $fromInt] "from"]
set to [my getInt32 $toInt "to"]
set length [my getInt32 [my strlen(STRING) $str] "length"]
my condBr [my or [my gt $from $to] [my gt $from $length]] \
$returnString $checkIfTrivial
label returnString "return.string"
my br $replaceDone
label returnSubstring "return.substring"
my br $replaceDone
label checkIfTrivial "check.trivial"
set to [my min $length $to "to"]
my condBr [my and [my eq $from $0] [my eq $to $length]] \
$returnSubstring $checkRemoveTail
label checkRemoveTail "check.remove.tail"
set length3 [my getInt32 [my strlen(STRING) $substr] "length3"]
set refCount [my refCount $str "refCount"]
my condBr [my and [my eq $length3 $0] [my eq $to $length]] \
$testUnshared $checkIfInPlace
label testUnshared "check.unshared"
my condBr [my le $refCount $1] $trimTail $checkIfInPlace
label trimTail "replace.remove.tail"
$api Tcl_SetObjLength $str $from
my br $returnString
label checkIfInPlace "check.in.place"
my condBr [my eq [my sub $length3 $1] [my sub $to $from]] \
$inPlace $complex
label inPlace "in.place"
my condBr [my le $refCount $1] $inPlaceTypecheck $inPlaceAlloc
label inPlaceAlloc "in.place.dup"
set allocated [$api Tcl_DuplicateObj $str]
my br $inPlaceTypecheck
label inPlaceTypecheck "in.place.typecheck"
set strIP [my phi [list $str $allocated] \
[list $inPlace $inPlaceAlloc]]
my condBr [my and \
[my isByteArray $strIP] \
[my isByteArray $substr]] \
$inPlaceBA $inPlaceUni
label inPlaceBA "in.place.bytes"
set bytes1 [$api Tcl_GetByteArray $strIP]
set bytes2 [$api Tcl_GetByteArray $substr]
my memcpy [my getelementptr $bytes1 [list $from]] $bytes2 $length3
$api TclInvalidateStringRep $strIP
my br $replaceDone
label inPlaceUni "in.place.unicode"
set bytes1 [$api Tcl_GetUnicode $strIP]
set bytes2 [$api Tcl_GetUnicode $substr]
my memcpy [my getelementptr $bytes1 [list $from]] $bytes2 \
[my mult $length3 $sizeof(Tcl_UniChar)]
my store $0 [my getelementptr [my cast(ptr) \
[my gep $strIP 0 Tcl_Obj.internalRep] int] [list $1]]
$api TclInvalidateStringRep $strIP
my br $replaceDone
label complex "replace"
lassign [my GetUnicode $str str] length ustring1
my condBr [my eq $length3 $0] $removeSubstr $replaceSubstr
label removeSubstr "replace.remove"
my condBr [my eq $from $0] $removeFront $removeBody
label removeFront "replace.remove.front"
set newstrFront [$api Tcl_NewUnicodeObj \
[my getelementptr $ustring1 [my add $to $1]] \
[list [my sub $length $to]]]
my br $replaceDone
label removeBody "replace.remove.body"
set newstr [$api Tcl_NewUnicodeObj $ustring1 $from]
my condBr [my lt $to $length] $removeBodyMid $replaceDone
label removeBodyMid "replace.remove.body.mid"
$api Tcl_AppendUnicodeToObj $newstr \
[my getelementptr $ustring1 [list [my add $to $1]]] \
[my sub $length $to]
my br $replaceDone
label replaceSubstr "replace.substr"
my condBr [my gt $from $0] $replaceMid $replaceFrontTest
label replaceFrontTest "replace.substr.front.test"
my condBr [my shared $substr] \
$replaceFrontShared $replaceFrontUnshared
label replaceMid "replace.substr.mid"
set newstrMid [$api Tcl_NewUnicodeObj $ustring1 $from]
$api Tcl_AppendObjToObj $newstrMid $substr
my condBr [my lt $to $length] $replaceTail $replaceDone
label replaceFrontShared "replace.substr.front.shared"
set newstrShared [$api Tcl_DuplicateObj $substr]
my condBr [my lt $to $length] $replaceTail $replaceDone
label replaceFrontUnshared "replace.subst.front.unshared"
my condBr [my lt $to $length] $replaceTail $replaceDone
label replaceTail "replace.subst.tail"
set sources [list $replaceMid $replaceFrontShared $replaceFrontUnshared]
set newstrTail [my phi [list $newstrMid $newstrShared $substr] \
$sources "tail"]
$api Tcl_AppendUnicodeToObj $newstrTail \
[my getelementptr $ustring1 [list [my add $to $1]]] \
[my sub [my sub $length $to] $1]
my br $replaceDone
label replaceDone "done"
set sources [list $returnString $returnSubstring $inPlaceBA \
$inPlaceUni $removeFront $removeBody $removeBodyMid \
$replaceMid $replaceFrontShared $replaceFrontUnshared \
$replaceTail]
set values [list $str $substr $strIP $strIP $newstrFront $newstr \
$newstr $newstrMid $newstrShared $substr $newstrTail]
set newstr [my phi $values $sources]
my addReference(STRING) $newstr
my ret $newstr
}
##### Function tcl.strreplace.idx #####
#
# Type signature: objPtr:STRING * fromIdx:STRING * toIdx:STRING *
# * substringPtr:STRING * ecvar:int* -> STRING?
#
# Quadcode implementation ('strreplace')
#
# Returns the string that has the substring of string 'objPtr' between
# indices 'fromIdx' and 'toIdx' (which are both internally clamped to
# the bounds of the string) replaced with the string 'substringPtr'.
set f [$m local "tcl.strreplace.idx" \
STRING?<-STRING,STRING,STRING,STRING,int*]
params str:stringPtr fromIdx toIdx substr:substringPtr ecvar
build {
noalias $ecvar
nonnull $str $fromIdx $toIdx $substr $ecvar
set interp [$api tclInterp]
set end [my sub [$api Tcl_GetCharLength $str] $1 "end"]
my condBr [my GetIndex $interp $fromIdx $end from] \
$getTo $failed
label getTo:
my condBr [my GetIndex $interp $toIdx $end to] \
$rangeCheck $failed
label rangeCheck:
set from [my packInt32 $from]
set to [my packInt32 $to]
set replaced [my Call tcl.strreplace $str $from $to $substr]
my ret [my just $replaced]
label failed:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.strmap #####
#
# Type signature: sourceObj:STRING * targetObj:STIRNG *
# stringObj:STRING -> STRING
#
# Quadcode implementation ('strmap')
#
# Returns the string that is a copy of string 'stringObj' with every
# occurrence of string 'sourceObj' replaced with string 'targetObj'.
set f [$m local "tcl.strmap" STRING<-STRING,STRING,STRING]
params sourceObj targetObj stringObj
build {
nonnull $sourceObj $targetObj $stringObj
my condBr [my eq $targetObj $sourceObj] $done $trivial1
label trivial1:
my condBr [my eq $stringObj $sourceObj] $done $trivial2
label trivial2:
lassign [my GetUnicode $stringObj "string"] strLen strPtr
my condBr [my eq $strLen $0] $done $trivial3
label trivial3:
lassign [my GetUnicode $sourceObj "source"] srcLen srcPtr
my condBr [my or [my gt $srcLen $strLen] [my eq $srcLen $0]] \
$done $trivial4
label trivial4:
my condBr [my eq $strLen $srcLen] $wholesale $map
label wholesale:
set cmp [my memcmp $strPtr $srcPtr \
[my mult $strLen $sizeof(Tcl_UniChar)]]
set wsres [my select [my eq $cmp $0] $targetObj $stringObj]
my br $done
label map:
lassign [my GetUnicode $targetObj "target"] tgtLen tgtPtr
set result [$api Tcl_NewUnicodeObj $strPtr $0]
set srcPtr0 [my load $srcPtr]
set prevLoop [my uniqueUndef [TypeOf $strPtr] "prev"]
set curLoop [my uniqueUndef [TypeOf $strPtr] "cur"]
set end [my getelementptr $strPtr [list $strLen]]
my br $maplooptest1
label maplooptest1 "map.loop.test"
set sources [list $map $maploopnext]
set cur [my phi [list $strPtr $curLoop] $sources "cur"]
set prev [my phi [list $strPtr $prevLoop] $sources "prev"]
my condBr [my lt $cur $end] $maplooptest2 $mapdone
label maplooptest2 "map.loop.test"
my condBr [my eq [my load $cur] $srcPtr0] \
$maplooptest3 $maploopnext
label maplooptest3 "map.loop.test"
my condBr [my eq $srcLen $1] $maplooptest5 $maplooptest4
label maplooptest4 "map.loop.test"
set cmp [my memcmp $cur $srcPtr \
[my mult $srcLen $sizeof(Tcl_UniChar)]]
my condBr [my eq $cmp $0] $maplooptest5 $maploopnext
label maplooptest5 "map.loop.test"
my condBr [my eq $prev $cur] $maploopbody1 $maploopbody2
label maploopbody1 "map.loop.body"
my br $maploopbody3
label maploopbody2 "map.loop.body"
$api Tcl_AppendUnicodeToObj $result $prev \
[my cast(int) [my diff $cur $prev] "len"]
my br $maploopbody3
label maploopbody3 "map.loop.body"
set sources [list $maploopbody1 $maploopbody2]
set prev2 [my phi [list $prev $cur] $sources "prev"]
set prev3 [my getelementptr $prev2 [list $srcLen] "prev"]
set cur2 [my getelementptr $prev3 [list ${-1}] "cur"]
$api Tcl_AppendUnicodeToObj $result $tgtPtr $tgtLen
my br $maploopnext
label maploopnext "map.loop.next"
set sources [list $maplooptest2 $maplooptest4 $maploopbody3]
set prev4 [my phi [list $prev $prev $prev3] $sources "prev"]
set cur3 [my phi [list $cur $cur $cur2] $sources "cur"]
ReplaceAllUsesWith $prevLoop $prev4
ReplaceAllUsesWith $curLoop \
[my getelementptr $cur3 [list $1] "cur"]
my br $maplooptest1
label mapdone "map.done"
my assume [my not [my shared $result]]
my condBr [my eq $prev $cur] $done $maplast
label maplast "map.addLast"
$api Tcl_AppendUnicodeToObj $result $prev \
[my cast(int) [my diff $cur $prev] "len"]
my assume [my not [my shared $result]]
my br $done
label done:
set sources [list $entry $trivial1 $trivial2 $trivial3 \
$wholesale $mapdone $maplast]
set result [my phi [list $stringObj $targetObj $stringObj \
$stringObj $wsres $result $result] $sources "result"]
my addReference(STRING) $result
my ret $result
}
##### Function tcl.strtrim #####
#
# Type signature: stringObj:STRING * trimsetObj:STRING * which:int32
# -> STRING
#
# Quadcode implementation ('strtrim')
#
# Returns the string that is a copy of 'stringObj' with the characters
# that are in the string 'trimsetObj' removed from the start and/or
# end. The 'which' parameter determines where the characters are to be
# removed from; when less than zero it removes from the beginning,
# when greater than zero from the end, and when zero it removes from
# both the beginning and the end.
set f [$m local "tcl.strtrim" STRING<-STRING,STRING,int]
params stringObj trimsetObj which
build {
nonnull $stringObj $trimsetObj
lassign [my GetString $stringObj "string"] stringLen string
lassign [my GetString $trimsetObj "trimset"] trimsetLen trimset
my condBr [my or [my eq $stringLen $0] [my eq $trimsetLen $0]] \
$returnString $okToSearch
label okToSearch:
my condBr [my le $which $0] $computeLeft $next
label computeLeft:
set left0 [my call ${tcl.impl.trimleft} [list \
$string $stringLen $trimset $trimsetLen] "left"]
my br $next
label next:
set sources [list $okToSearch $computeLeft]
set left [my phi [list $0 $left0] $sources "left"]
my condBr [my and [my ge $which $0] [my lt $left $stringLen]] \
$computeRight $createTrimmedString
label computeRight:
set right0 [my call ${tcl.impl.trimright} [list \
$string $stringLen $trimset $trimsetLen] "right"]
my br $createTrimmedString
label createTrimmedString:
set sources [list $next $computeRight]
set right [my phi [list $0 $right0] $sources "right"]
my condBr [my and [my eq $left $0] [my eq $right $0]] \
$returnString $doTrim
label doTrim:
set result [$api Tcl_NewStringObj \
[my getelementptr $string [list $left] "C"] \
[my sub [my sub $stringLen $left "A"] $right "B"]]
my br $returnString
label returnString:
set sources [list $entry $createTrimmedString $doTrim]
set result [my phi [list $stringObj $stringObj $result] $sources \
"result"]
my addReference(STRING) $result
my ret $result
}
##### Function tcl.strcase #####
#
# Type signature: string:STRING * kind:int32 -> STRING
#
# Quadcode implementation ('strrange')
#
# Returns the string that is a copy of 'string' with the case
# transformation described in 'kind' applied. 0 means convert to upper
# case, 1 means convert to lower case, and 2 means convert to title
# case.
set f [$m local "tcl.strcase" STRING<-STRING,int]
params string kind
build {
nonnull $string
my condBr [my shared $string] $duplicate $apply
label duplicate:
lassign [my GetString $string "string"] l1 s1
set copy [$api Tcl_NewStringObj $s1 $l1]
my br $apply
label apply:
set sources [list $entry $duplicate]
set string [my phi [list $string $copy] $sources "string"]
set copied [my phi [list [Const false bool] [Const true bool]] \
$sources "copied"]
set content [$api Tcl_GetString $string]
my switch $kind $title 0 $upper 1 $lower
label upper:
set len1 [$api Tcl_UtfToUpper $content]
my br $setLength
label lower:
set len2 [$api Tcl_UtfToLower $content]
my br $setLength
label title:
set len3 [$api Tcl_UtfToTitle $content]
my br $setLength
label setLength "set.length"
set length [my phi [list $len1 $len2 $len3] \
[list $upper $lower $title] "length"]
$api Tcl_SetObjLength $string $length
my condBr $copied $releaseIntRep $done
label releaseIntRep "release.internal.representation"
$api TclFreeIntRep $string
my br $done
label done:
my addReference(STRING) $string
my ret $string
}
##### Function tcl.impl.listDupe #####
##### Closure Build:ListDupe #####
#
# Type signature: interp:Tcl_Interp* * obj:STRING -> STRING
#
# Replacement for non-exposed TclListObjCopy().
set f [$m local "tcl.impl.listDupe" STRING<-Tcl_Interp*,STRING]
unset -nocomplain interp objPtr name
my closure ListDupe {interp objPtr {name ""}} {
if {$interp eq ""} {
set interp [my null Tcl_Interp*]
}
my call ${tcl.impl.listDupe} [list $interp $objPtr] $name
}
params interp obj
build {
noalias $interp $obj
nonnull $obj
set listType [$api tclListType]
set typePtr [my dereference $obj 0 Tcl_Obj.typePtr]
my condBr [my neq $typePtr $listType] \
$forceType $ok
label forceType:
my condBr [my eq [my setFromAny $listType $interp $obj] $0] \
$ok $fail
label ok:
set new [$api Tcl_NewObj]
$api TclInvalidateStringRep $new
set func [my cast(ptr) \
[my dereference $listType 0 Tcl_ObjType.dupIntRepProc]\
func{void<-Tcl_Obj*,Tcl_Obj*} "dupIntRep"]
set call [my Call $func $obj $new]
AddCallAttribute $call 1 nocapture
AddCallAttribute $call 2 nocapture
my ret $new
label fail:
my ret [my null STRING]
}
##### Function tcl.list.create #####
#
# Type signature: objc:int * objv:STRING* -> STRING
#
# Core of quadcode implementation ('list')
#
# Wrapper around Tcl_NewListObj that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.create" STRING<-int,STRING*]
params objc objv
build {
nonnull $objv
set val [$api Tcl_NewListObj $objc $objv]
my addReference(STRING) $val
my ret $val
}
##### Function tcl.list.length #####
#
# Type signature: list:STRING * ecvar:int* -> INT?
#
# Core of quadcode implementation ('listLength')
#
# Wrapper around Tcl_ListObjLength that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.length" INT?<-STRING,int*]
params list ecvar
build {
noalias $list $ecvar
nonnull $list $ecvar
set interp [$api tclInterp]
set var [my alloc int "length"]
set code [$api Tcl_ListObjLength $interp $list $var]
my condBr [my eq $code $0] $ok $fail
label ok:
my ret [my cast(INT?) [my load $var]]
label fail:
my store $1 $ecvar
my ret [my nothing INT]
}
##### Function tcl.list.append #####
#
# Type signature: list:STRING * value:STRING * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('listAppend')
#
# Wrapper around Tcl_ListObjLength that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.append" STRING?<-STRING,STRING,int*]
params list value ecvar
build {
noalias $ecvar
nonnull $list $value $ecvar
set interp [$api tclInterp]
my condBr [my shared $list] $sharedDupe $unshared
label sharedDupe "shared.duplicate"
set copy [my ListDupe $interp $list "copy"]
my condBr [my nonnull $copy] $shared $error
label shared:
$api Tcl_ListObjAppendElement {} $copy $value
my br $return
label unshared:
set code [$api Tcl_ListObjAppendElement $interp $list $value]
my condBr [my eq $code $0] $return $error
label return:
set list [my phi [list $copy $list] [list $shared $unshared] "list"]
$api TclInvalidateStringRep $list
my addReference(STRING) $list
my condBr [my shared $value] $exit $extraRef
label extraRef "add.extra.reference.to.value"
my addReference(STRING) $value
my br $exit
label exit:
my ret [my just $list]
label error:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.list.concat #####
#
# Type signature: list:STRING * value:STRING * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('listConcat')
#
# Wrapper around Tcl_ListObjLength that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.concat" STRING?<-STRING,STRING,int*]
params list value ecvar
build {
noalias $ecvar
nonnull $list $value $ecvar
set interp [$api tclInterp]
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set code [$api Tcl_ListObjLength $interp $list $objc]
my condBr [my eq $code $0] $checkValue $error
label checkValue "check.value.for.listness"
set len [my load $objc "len"]
set code [$api Tcl_ListObjGetElements $interp $value $objc $objv]
my condBr [my eq $code $0] $checkDupe $error
label checkDupe "check.whether.to.duplicate"
my condBr [my shared $list] $dupe $concat
label dupe "duplicate"
set copy [my ListDupe {} $list "copy"]
my br $concat
label concat:
set working [my phi [list $list $copy] [list $checkDupe $dupe] "list"]
set objc [my load $objc "objc"]
set objv [my load $objv "objv"]
$api Tcl_ListObjReplace {} $working $len $0 $objc $objv
my addReference(STRING) $working
my ret [my just $working]
label error:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.list.index #####
#
# Type signature: list:STRING * idxc:int * idxv:STRING* * ecvar:int*
# -> STRING?
#
# Core of quadcode implementation ('listIndex')
#
# Effectively an implementation of TclLindexFlat.
set f [$m local "tcl.list.index" STRING?<-STRING,int,STRING*,int*]
params list idxc idxv ecvar
build {
noalias $list $idxv $ecvar
nonnull $list $idxv $ecvar
set interp [$api tclInterp]
set iPtr [my alloc int "&i"]
set listPtr [my alloc STRING "&list"]
set listLenPtr [my alloc int "&listLen"]
set elemPtrsPtr [my alloc STRING* "&elemPtrs"]
my addReference(STRING) $list
my store $0 $iPtr
my store $list $listPtr
my br $loopTest
label loopTest:
set i [my load $iPtr "i"]
set list [my load $listPtr "list"]
my condBr [my and [my lt $i $idxc] [my nonnull $list]] \
$loop $done
label loop:
my store $0 $listLenPtr
my store [my null STRING*] $elemPtrsPtr
set sublistCopy [my ListDupe $interp $list "sublistCopy"]
my dropReference $list
my store [my null STRING] $listPtr
my condBr [my nonnull $sublistCopy] $loop2 $error
label loop2:
$api Tcl_ListObjGetElements {} $sublistCopy $listLenPtr $elemPtrsPtr
set listLen [my load $listLenPtr "listLen"]
set elemPtrs [my load $elemPtrsPtr "elemPtrs"]
my condBr [my GetIndex $interp \
[my load [my getelementptr $idxv [list $i]]] \
[my sub $listLen $1] index] \
$loopIndex $loopNext
label loopIndex:
my condBr [my and [my ge $index $0] [my lt $index $listLen]] \
$loopIndexInRange $loopIndexOutOfRange
label loopIndexInRange:
set list [my load [my getelementptr $elemPtrs [list $index]] "list"]
my store $list $listPtr
my addReference(STRING) $list
my br $loopNext
label loopIndexOutOfRange:
my store [set i [my add [my load $iPtr] $1 "i"]] $iPtr
my condBr [my lt $i $idxc] $loopIndexValidityCheck $loopEmpty
label loopEmpty:
my store [set list [$api Tcl_NewObj]] $listPtr
my addReference(STRING) $list
my br $loopNext
label loopIndexValidityCheck:
my condBr [my GetIndex $interp \
[my load [my getelementptr $idxv [list $i]]] [Const -1]] \
$loopIndexOutOfRange $loopIndexBad
label loopIndexBad:
my dropReference $sublistCopy
my br $error
label loopNext:
my dropReference $sublistCopy
my store [my add [my load $iPtr "i"] $1] $iPtr
my br $loopTest
label done:
set list [my load $listPtr "list"]
my ret [my just $list]
label error:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.list.index1 #####
#
# Type signature: list:STRING * index:INT * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('listIndex')
#
# Basic list indexing in the case where we know that the index is an
# integer, which avoids many of the failure modes.
set f [$m local "tcl.list.index1" STRING?<-STRING,INT,int*]
params list index ecvar
build {
noalias $list $ecvar
nonnull $list $ecvar
set interp [$api tclInterp]
set idx [my getInt32 $index]
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set code [$api Tcl_ListObjGetElements $interp $list $objc $objv]
my condBr [my eq $code $0] $ok $fail
label ok:
my condBr [my and [my ge $idx $0] [my lt $idx [my load $objc]]] \
$realIndex $outOfBounds
label realIndex "real.index"
set objv [my load $objv "objv"]
set obj [my load [my getelementptr $objv [list $idx]] "objPtr"]
my addReference(STRING) $obj
my ret [my just $obj]
label outOfBounds "out.of.bounds"
set obj [$api Tcl_NewObj]
my addReference(STRING) $obj
my ret [my just $obj]
label fail:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.list.indexList #####
#
# Type signature: list:STRING * index:STRING * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('listIndex')
#
# Effectively an implementation of TclLindexList.
set f [$m local "tcl.list.indexList" STRING?<-STRING,STRING,int*]
params list index ecvar
build {
noalias $ecvar
nonnull $list $index $ecvar
set interp [$api tclInterp]
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set code [$api Tcl_ListObjGetElements $interp $list $objc $objv]
my condBr [my eq $code $0] $checkType $notList
label notList:
# We're not a list and we know it right now
my store $1 $ecvar
my ret [my nothing STRING]
label checkType:
my condBr [my neq [my dereference $index 0 Tcl_Obj.typePtr] \
[$api tclListType]] \
$checkIndex $slowPath
label checkIndex:
set len [my load $objc]
my condBr [my GetIndex {} $index $len idx] \
$immediateIndex $slowPath
label immediateIndex:
my condBr [my and [my ge $idx $0] [my lt $idx $len]] \
$realIndex $outOfBounds
label realIndex "real.index"
set objv [my load $objv "objv"]
set obj [my load [my getelementptr $objv [list $idx]] "objPtr"]
my addReference(STRING) $obj
my ret [my just $obj]
label outOfBounds "out.of.bounds"
set obj [$api Tcl_NewObj]
my addReference(STRING) $obj
my ret [my just $obj]
label slowPath:
set dupe [my ListDupe $interp $index "copy"]
my condBr [my nonnull $dupe] $okIndex $notList
label okIndex:
set listRep [my load [my cast(ptr) \
[my gep $dupe 0 Tcl_Obj.internalRep 0] \
TclList*] "listRep"]
set result [my Call tcl.list.index \
$list [my dereference $listRep 0 TclList.elemCount] \
[my gep $listRep 0 TclList.elements] $ecvar]
my dropReference $dupe
my ret $result
}
##### Function tcl.list.range #####
#
# Type signature: list:STRING * from:STRING * to:STRING -> STRING?
#
# Core of quadcode implementation ('listRangeImm')
#
# Wrapper around Tcl_NewListObj that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.range" STRING?<-STRING,STRING,STRING,int*]
params list from to ecvar
build {
noalias $ecvar
nonnull $list $from $to $ecvar
set interp [$api tclInterp]
set objcVar [my alloc int]
set objvVar [my alloc STRING*]
set result [$api Tcl_ListObjLength $interp $list $objcVar]
my condBr [my eq $result $0] $getFrom $error
label getFrom:
set objc [my load $objcVar "objc"]
set endIndex [my sub $objc $1]
my condBr [my GetIndex $interp $from $endIndex from] $getTo $error
label getTo:
my condBr [my GetIndex $interp $to $endIndex to] $clamp $error
label clamp:
set from [my select [my lt $from ${-1}] \
[my add $from [my add $1 $objc]] \
[my min $objc $from] \
"from"]
set from [my max ${-1} $from "from"]
set to [my select [my lt $to ${-1}] \
[my add $to [my add $1 $objc]] \
[my min $objc $to] \
"to"]
set to [my max ${-1} $to "to"]
my condBr [my and [my le $from $to] \
[my and [my lt $from $objc] [my ge $to $0]]] \
$sublist $empty
label sublist:
$api Tcl_ListObjGetElements {} $list $objcVar $objvVar
set objv [my load $objvVar "objv"]
set from [my max $0 $from "from"]
set to [my min [my sub $objc $1] $to "to"]
my condBr [my and [my eq $from $0] [my and \
[my neq $to [my sub $objc $1]] \
[my not [my shared $list]]]] \
$sublistCheck $sublistNew
label sublistCheck "sublist.inPlace.check"
# WARNING: BEWARE! This is looking inside the implementation of
# the list type.
set listPtr [my load [my cast(ptr) \
[my gep $list 0 Tcl_Obj.internalRep 0] \
TclList*] "listPtr"]
my condBr [my eq [my dereference $listPtr 0 TclList.refCount] $1] \
$sublistInplace $sublistNew
label sublistInplace "sublist.inPlace"
set onePast [my add $to $1 "onePast"]
set loopIndex [my uniqueUndef int "index"]
my br $sublistInplaceFreeTest
label sublistInplaceFreeTest "sublist.inPlace.loop.test"
set sources [list $sublistInplace $sublistInplaceFree]
set index [my phi [list $onePast $loopIndex] $sources "index"]
my condBr [my lt $index $objc] \
$sublistInplaceFree $sublistInplaceDone
label sublistInplaceFree "sublist.inPlace.loop.body"
ReplaceAllUsesWith $loopIndex [my add $index $1 "index"]
set obj [my load [my getelementptr $objv [list $index]] "objPtr"]
my dropReference $obj
my br $sublistInplaceFreeTest
label sublistInplaceDone "sublist.inPlace.done"
my storeInStruct $listPtr TclList.elemCount $onePast
my storeInStruct $listPtr TclList.canonicalFlag $1
$api TclInvalidateStringRep $list
my br $ok
label sublistNew "sublist.new"
set r1 [$api Tcl_NewListObj [my add [my sub $to $from] $1] \
[my getelementptr $objv [list $from]]]
my br $ok
label empty:
set r2 [$api Tcl_NewObj]
my br $ok
label ok:
set sources [list $sublistInplaceDone $sublistNew $empty]
set result [my phi [list $list $r1 $r2] $sources "result"]
my addReference(STRING) $result
my ret [my just $result]
label error:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.list.range1 #####
#
# Type signature: list:STRING * from:INT * to:INT -> STRING?
#
# Core of quadcode implementation ('listRangeImm')
#
# Wrapper around Tcl_NewListObj that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.range1" STRING?<-STRING,INT,INT,int*]
params list from to ecvar
build {
noalias $ecvar
nonnull $list $ecvar
set interp [$api tclInterp]
set from [my getInt32 $from "from"]
set to [my getInt32 $to "to"]
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set result [$api Tcl_ListObjGetElements $interp $list $objc $objv]
my condBr [my eq $result $0] $clamp $error
label clamp:
set objc [my load $objc]
set objv [my load $objv]
set from [my select [my lt $from ${-1}] \
[my add $from [my add $1 $objc]] \
[my min $objc $from] \
"from"]
set from [my max ${-1} $from "from"]
set to [my select [my lt $to ${-1}] \
[my add $to [my add $1 $objc]] \
[my min $objc $to] \
"to"]
set to [my max ${-1} $to "to"]
my condBr [my and [my le $from $to] \
[my and [my lt $from $objc] [my ge $to $0]]] \
$sublist $empty
label sublist:
set from [my max $0 $from "from"]
set to [my min [my sub $objc $1] $to "to"]
my condBr [my and [my eq $from $0] [my and \
[my neq $to [my sub $objc $1]] \
[my not [my shared $list]]]] \
$sublistCheck $sublistNew
label sublistCheck "sublist.inPlace.check"
# WARNING: BEWARE! This is looking inside the implementation of
# the list type.
set listPtr [my load [my cast(ptr) \
[my gep $list 0 Tcl_Obj.internalRep 0] \
TclList*] "listPtr"]
my condBr [my eq [my dereference $listPtr 0 TclList.refCount] $1] \
$sublistInplace $sublistNew
label sublistInplace "sublist.inPlace"
set onePast [my add $to $1 "onePast"]
set loopIndex [my uniqueUndef int "index"]
my br $sublistInplaceFreeTest
label sublistInplaceFreeTest "sublist.inPlace.free.test"
set sources [list $sublistInplace $sublistInplaceFree]
set index [my phi [list $onePast $loopIndex] $sources "index"]
my condBr [my lt $index $objc] \
$sublistInplaceFree $sublistInplaceDone
label sublistInplaceFree "sublist.inPlace.free"
ReplaceAllUsesWith $loopIndex [my add $index $1 "index"]
set obj [my load [my getelementptr $objv [list $index]] "objPtr"]
my dropReference $obj
my br $sublistInplaceFreeTest
label sublistInplaceDone "sublist.inPlace.done"
my storeInStruct $listPtr TclList.elemCount $onePast
my storeInStruct $listPtr TclList.canonicalFlag $1
$api TclInvalidateStringRep $list
my br $ok
label sublistNew "sublist.new"
set r1 [$api Tcl_NewListObj [my add [my sub $to $from] $1] \
[my getelementptr $objv [list $from]]]
my br $ok
label empty:
set r2 [$api Tcl_NewObj]
my br $ok
label ok:
set sources [list $sublistInplaceDone $sublistNew $empty]
set result [my phi [list $list $r1 $r2] $sources "result"]
my addReference(STRING) $result
my ret [my just $result]
label error:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.list.set #####
#
# Type signature: list:STRING * idxc:int * idxv:STRING* * elem:STRING
# * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('lset')
#
# Approximately equivalent to TclLsetFlat
set f [$m local "tcl.list.set" STRING?<-STRING,int,STRING*,STRING,int*]
params list idxc idxv elem ecvar
build {
noalias $idxv $ecvar
nonnull $list $idxv $elem $ecvar
set interp [$api tclInterp]
my condBr [my eq $idxc $0] $doNothing $sharedCheck
label doNothing:
my addReference(STRING) $list
my ret [my just $list]
label sharedCheck:
my condBr [my shared $list] $duplicate $prepareToLoop
label duplicate:
set dupe [$api Tcl_DuplicateObj $list]
my br $prepareToLoop
label prepareToLoop:
set sources [list $sharedCheck $duplicate]
set retValue [my phi [list $list $dupe] $sources "retValue"]
set subList [my alloc STRING]
set chain [my alloc STRING]
set elemc [my alloc int]
set elemv [my alloc STRING*]
set idxArray [my alloc STRING*]
set idxCount [my alloc int]
my store $retValue $subList
my store [my null STRING] $chain
my store $idxv $idxArray
my store $idxc $idxCount
my br $loop1
label loop1:
my condBr [my neq [$api Tcl_ListObjGetElements $interp \
[my load $subList] $elemc $elemv] $0] $loopFail $loop2
label loop2:
set elemCount [my load $elemc "elemCount"]
set elemPtrs [my load $elemv "elemPtrs"]
set indexArray [my load $idxArray "indexArray"]
my condBr [my GetIndex $interp [my load $indexArray] \
[my load $elemc] index] \
$loop3 $loopFail
label loop3:
my store [my gep $indexArray 1] $idxArray
my condBr [my or [my lt $index $0] [my gt $index $elemCount]] \
$loopRangeFail $loop4
label loop4:
set idxc [my sub [my load $idxCount] $1]
my store $idxc $idxCount
my condBr [my gt $idxc $0] $loop5 $loopEnd
label loop5:
set parent [my load $subList]
my condBr [my eq $index $elemCount] $newElem $existingElem
label newElem:
set newSublist [$api Tcl_NewObj]
my br $loop6
label existingElem:
set existingSublist [my load [my getelementptr $elemPtrs [list $index]]]
my condBr [my shared $existingSublist] $dupeElem $loop6
label dupeElem:
set dupeSublist [$api Tcl_DuplicateObj $existingSublist]
my br $loop6
label loop6:
set sublist [my phi \
[list $newSublist $existingSublist $dupeSublist] \
[list $newElem $existingElem $dupeElem] "sublist"]
my store $sublist $subList
my condBr [my eq $index $elemCount] $appendSublist $setSublist
label appendSublist:
$api Tcl_ListObjAppendElement {} $parent $sublist
my br $loop7
label setSublist:
$api TclListObjSetElement {} $parent $index $sublist
my br $loop7
label loop7:
my condBr [my shared $sublist] $mustDuplicate $loop8
label mustDuplicate:
set dupeSublist [$api Tcl_DuplicateObj $sublist]
$api TclListObjSetElement {} $parent $index $dupeSublist
my br $loop8
label loop8:
my store [my load $chain] \
[my cast(ptr) [my gep $parent 0 Tcl_Obj.internalRep 1] STRING]
my store $parent $chain
my br $loop1
label loopRangeFail:
$api Tcl_SetObjResult $interp \
[$api obj.constant "list index out of range"]
$api Tcl_SetObjErrorCode $interp \
[$api obj.constant {TCL OPERATION LSET BADINDEX}]
my br $loopEnd
label loopFail:
set obj [my load $chain]
my condBr [my nonnull $obj] $loopFailDrop $loopFailDone
label loopFailDrop:
set ptr2 [my cast(ptr) [my gep $obj 0 Tcl_Obj.internalRep 1] STRING]
my store [my load $ptr2] $chain
my store [my null STRING] $ptr2
my br $loopFail
label loopFailDone:
my condBr [my neq $retValue $list] \
$loopFailDropOverall $loopFailExit
label loopFailDropOverall:
my dropReference $retValue
my br $loopFailExit
label loopFailExit:
my store $1 $ecvar
my ret [my nothing STRING]
label loopEnd:
set sublist [my load $subList]
set obj [my load $chain]
my condBr [my nonnull $obj] $loopEndDrop $terminalSet
label loopEndDrop:
set ptr2 \
[my cast(ptr) [my gep $obj 0 Tcl_Obj.internalRep 1] STRING]
my store [my load $ptr2] $chain
my store [my null STRING] $ptr2
$api TclInvalidateStringRep $obj
my br $loopEnd
label terminalSet:
$api Tcl_ListObjLength {} $sublist $elemc
my condBr [my eq $index [my load $elemc]] $termSetAdd $termSetSet
label termSetAdd:
$api Tcl_ListObjAppendElement {} $sublist $elem
my br $exit
label termSetSet:
$api TclListObjSetElement {} $sublist $index $elem
my br $exit
label exit:
$api TclInvalidateStringRep $sublist
my addReference(STRING) $retValue
my condBr [my shared $elem] $exit2 $exit3
label exit3 "exit"
my addReference(STRING) $elem
my br $exit2
label exit2 "exit"
my ret [my just $retValue]
}
##### Function tcl.list.set1 #####
#
# Type signature: list:STRING * index:INT * elem:STRING * ecvar:int*
# -> STRING?
#
# Core of quadcode implementation ('lset')
#
# Wrapper around TclListObjSetElement that exposes it to the general
# instruction issuing code.
set f [$m local "tcl.list.set1" STRING?<-STRING,INT,STRING,int*]
params list idx elem ecvar
build {
noalias $ecvar
nonnull $list $elem $ecvar
set idx [my getInt32 $idx "index"]
set interp [$api tclInterp]
set duped [my Dedup list]
set objc [my alloc int "objc"]
set objv [my alloc STRING* "objv"]
set code [$api Tcl_ListObjGetElements $interp $list $objc $objv]
my condBr [my eq $code $1] $out $rangeCheck
label rangeCheck "range.check"
set objc [my load $objc]
my condBr [my or [my lt $idx $0] [my gt $idx $objc]] \
$outRange $checkOperation
label checkOperation "operation.check"
set rc [my refCount $list]
my condBr [my eq $idx $objc] $append $set
label append:
$api Tcl_ListObjAppendElement {} $list $elem
my br $done
label set:
set call [$api TclListObjSetElement {} $list $idx $elem]
my br $done
label done:
my assume [my eq $rc [my refCount $list]]
$api TclInvalidateStringRep $list
my addReference(STRING) $list
my condBr [my shared $elem] $exit2 $exit3
label exit3 "exit"
my addReference(STRING) $elem
my br $exit2
label exit2 "exit"
my ret [my just $list]
label outRange "failure.outOfRange"
$api Tcl_SetObjResult $interp \
[$api obj.constant "list index out of range"]
$api Tcl_SetObjErrorCode $interp \
[$api obj.constant {TCL OPERATION LSET BADINDEX}]
my br $out
label out "failure.exit"
my Call obj.cleanup $duped
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.list.setList #####
#
# Type signature: list:STRING * idxArg:STRING * elem:STRING
# * ecvar:int* -> STRING?
#
# Core of quadcode implementation ('lset')
#
# Approximately equivalent to TclLsetList
set f [$m local "tcl.list.setList" STRING?<-STRING,STRING,STRING,int*]
params list idxArg elem ecvar
build {
noalias $ecvar
nonnull $list $idxArg $elem $ecvar
my condBr [my eq [my dereference $idxArg 0 Tcl_Obj.typePtr] [$api tclListType]] \
$doCopy $checkIndex
label checkIndex "check.index"
my condBr [my GetIndex {} $idxArg $0] $doFlat $doCopy
label doFlat "flat"
set ary [my alloc STRING]
my store $idxArg $ary
my ret [my Call tcl.list.set $list $1 $ary $elem $ecvar]
label doCopy "copy"
set argc [my alloc int]
set argv [my alloc STRING*]
set code [$api Tcl_ListObjGetElements {} $idxArg $argc $argv]
my condBr [my eq $code $0] $doCopy2 $doFlat
label doCopy2 "delegate"
set copy [$api Tcl_NewListObj [my load $argc] [my load $argv]]
$api Tcl_ListObjGetElements {} $copy $argc $argv
set code [my Call tcl.list.set \
$list [my load $argc] [my load $argv] $elem $ecvar]
my dropReference $copy
my ret $code
}
##### Function tcl.list.in #####
#
# Type signature: value:STRING * list:STRING * ecVar:int* -> ZEROONE?
#
# Core of quadcode implementation ('listIn')
#
# Determines if the value is present in the list, using simple string
# comparison.
set f [$m local "tcl.list.in" ZEROONE?<-STRING,STRING,int*]
params value list ecVar
build {
noalias $ecVar
nonnull $value $list $ecVar
set interp [$api tclInterp]
lassign [my GetString $value "string"] len1 bytes1
set lenVar [my alloc int]
set objvVar [my alloc STRING*]
set code [$api Tcl_ListObjGetElements $interp $list $lenVar $objvVar]
my condBr [my eq $code $0] $realCheck $fail
label realCheck:
set objc [my load $lenVar "objc"]
set objv [my load $objvVar "objv"]
set iLoop [my uniqueUndef int "i"]
my condBr [my gt $objc $0] $loop $done
label loop:
set i [my phi [list $0 $iLoop] [list $realCheck $loopNext] "i"]
set obj [my load [my getelementptr $objv [list $i]] "obj"]
lassign [my GetString $obj "element"] len2 bytes2
my condBr [my eq $len1 $len2] $loopCompare $loopNext
label loopCompare:
my condBr [my eq [my memcmp $bytes1 $bytes2 $len1] $0] \
$done $loopNext
label loopNext:
ReplaceAllUsesWith $iLoop [set i [my add $i $1 "i"]]
my condBr [my lt $i $objc] $loop $done
label fail:
my store $1 $ecVar
my ret [my nothing ZEROONE]
label done:
set flag [my phi [list [Const false bool] [Const false bool] [Const true bool]] \
[list $realCheck $loopNext $loopCompare] "flag"]
my ret [my just $flag]
}
##### Function tcl.list.unshare #####
#
# Type signature: list:STRING -> STRING
#
# Core of quadcode implementation ('unshareList')
#
# Approximately equivalent to TclListObjCopy
set f [$m local "tcl.list.unshare" STRING<-STRING]
params list
build {
nonnull $list
my condBr [my shared $list] $unshare $done
label unshare:
set copy [my ListDupe {} $list "copy"]
my br $done
label done:
set copy [my phi [list $list $copy] [list $entry $unshare] "copy"]
my addReference(STRING) $copy
my ret $copy
}
##### Function tcl.list.foreach.start #####
#
# Type signature: len:int * varListLength:int* * listArray:STRING*
# * ecvar:int* -> FOREACH?
#
# Core of quadcode implementation ('foreachStart')
#
# Applies runtime checks to determine the number of iterations to make
# (at most) and work out whether the lists are really lists.
set f [$m local "tcl.list.foreach.start" FOREACH?<-int,int*,STRING*,int*]
params len varListLength listArray ecVar
build {
noalias $varListLength $listArray $ecVar
nonnull $varListLength $listArray $ecVar
set interp [$api tclInterp]
set objcVar [my alloc int]
set maxLoop [my uniqueUndef int "max"]
set iLoop [my uniqueUndef int "i"]
my br $loopStart
label loopStart:
set sources [list $entry $loopMax]
set max [my phi [list $0 $maxLoop] $sources "max"]
set i [my phi [list $0 $iLoop] $sources "i"]
my condBr [my lt $i $len] $loopBody $ok
label loopBody:
set numVars [my load [my getelementptr $varListLength [list $i]] "numVars"]
set listPtr [my load [my getelementptr $listArray [list $i]] "listPtr"]
set code [$api Tcl_ListObjLength $interp $listPtr $objcVar]
my condBr [my eq $code $0] $loopMax $fail
label loopMax:
set objc [my load $objcVar "objc"]
set iterTmp [my div [my add $objc [my sub $numVars $1]] $numVars]
ReplaceAllUsesWith $maxLoop [my max $iterTmp $max "max"]
ReplaceAllUsesWith $iLoop [my add $i $1 "i"]
my br $loopStart
label ok:
set pair [my undef FOREACH]
set pair [my insert $pair $0 FOREACH.val]
set pair [my insert $pair $max FOREACH.max]
my ret [my just $pair]
label fail:
my store $1 $ecVar
my ret [my nothing FOREACH]
}
##### Function tcl.list.foreach.getStep #####
#
# Type signature: pair:FOREACH -> INT
#
# Core of quadcode implementation ('foreachIter')
#
# Part of how lists are iterated over. This is broken up into several
# pieces because of the number of different things assigned to. This
# part gets the iteration count.
set f [$m local "tcl.list.foreach.getStep" INT<-FOREACH readnone]
params pair
build {
my ret [my packInt32 [my extract $pair FOREACH.val]]
}
##### Function tcl.list.foreach.mayStep #####
#
# Type signature: pair:FOREACH -> ZEROONE
#
# Core of quadcode implementation ('foreachMayStep')
#
# Part of how lists are iterated over. This is broken up into several
# pieces because of the number of different things assigned to. This
# part gets whether the end of the iterations has been reached.
set f [$m local "tcl.list.foreach.mayStep" ZEROONE<-FOREACH readnone]
params pair
build {
set val [my extract $pair FOREACH.val]
set max [my extract $pair FOREACH.max]
my ret [my lt $val $max]
}
##### Function tcl.list.foreach.nextStep #####
#
# Type signature: pair:FOREACH -> FOREACH
#
# Core of quadcode implementation ('foreachAdvance')
#
# Part of how lists are iterated over. This is broken up into several
# pieces because of the number of different things assigned to. This
# part computes the next iteration step.
set f [$m local "tcl.list.foreach.nextStep" FOREACH<-FOREACH readnone]
params pair
build {
set val [my extract $pair FOREACH.val]
my ret [my insert $pair [my add $val $1] FOREACH.val]
}
##### Function tcl.dict.exists1 #####
#
# Type signature: dict:STRING * key:STRING -> ZEROONE
#
# Tests if a key is in a dictionary.
set f [$m local "tcl.dict.exists1" ZEROONE<-STRING,STRING]
params dict key
build {
nonnull $dict $key
set resvar [my alloc STRING "valueVar"]
my store [my null STRING] $resvar
set result [$api Tcl_DictObjGet {} $dict $key $resvar]
my ret [my and [my eq $result $0] \
[my nonnull [my load $resvar "value"]] \
"exists"]
}
##### Function tcl.dict.exists #####
#
# Type signature: dict:STRING * pathlen:int * pathobjs:STRING*
# * ecvar:int32* -> ZEROONE
#
# Gets a value by key from a dictionary. Can fail if the "dict" is
# not a valid dictionary.
set f [$m local "tcl.dict.exists" ZEROONE<-STRING,int,STRING*]
params dict keyc keyv
build {
noalias $dict $keyv
nonnull $dict $keyv
my condBr [my eq $keyc $0] $verify $exists
label verify:
set dummy [my alloc int "dummy"]
set code [$api Tcl_DictObjSize {} $dict $dummy]
my ret [my eq $code $0]
label exists:
set n [my sub $keyc $1]
set dict [$api TclTraceDictPath {} $dict $n $keyv $0]
SetValueName $dict "dictObj"
my condBr [my nonnull $dict] $lookup $notOK
label lookup:
set resvar [my alloc STRING "valueVar"]
my store [my null STRING] $resvar
set key [my load [my getelementptr $keyv [list $n]] "key"]
set result [$api Tcl_DictObjGet {} $dict $key $resvar]
my ret [my and [my eq $result $0] \
[my nonnull [my load $resvar "value"]] \
"exists"]
label notOK:
my ret [Const false bool]
}
##### Function tcl.dict.size #####
#
# Type signature: dict:STRING * ecvar:int32* -> INT?
#
# Gets the size of a dictionary. Can fail if the "dict" is not a valid
# dictionary.
set f [$m local "tcl.dict.size" INT?<-STRING,int*]
params dict ecvar
build {
noalias $ecvar
nonnull $dict $ecvar
set interp [$api tclInterp]
set size [my alloc int "size"]
set code [$api Tcl_DictObjSize $interp $dict $size]
my condBr [my eq $code $0] $ok $fail
label ok:
my ret [my cast(INT?) [my load $size]]
label fail:
my store $1 $ecvar
my ret [my nothing INT]
}
##### Function tcl.dict.get1 #####
#
# Type signature: dict:STRING * key:STRING * ecvar:int32* -> STRING?
#
# Gets a value by key from a dictionary. Can fail if the "dict" is
# not a valid dictionary.
set f [$m local "tcl.dict.get1" STRING?<-STRING,STRING,int*]
params dict key ecvar
build {
noalias $ecvar
nonnull $dict $key $ecvar
set interp [$api tclInterp]
set resvar [my alloc STRING "valueVar"]
set result [$api Tcl_DictObjGet $interp $dict $key $resvar]
my condBr [my eq $result $0] $OK $notOK
label OK:
set value [my load $resvar "value"]
my condBr [my nonnull $value] $return $fail
label return:
my addReference(STRING) $value
my ret [my just $value]
label fail:
set keyval [$api Tcl_GetString $key]
$api Tcl_SetObjResult $interp \
[$api Tcl_ObjPrintf [my constString \
"key \"%s\" not known in dictionary"] \
$keyval]
$api Tcl_SetErrorCode $interp \
[my constString TCL] [my constString LOOKUP] \
[my constString DICT] $keyval [my null char*]
my br $notOK
label notOK:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.dict.get #####
#
# Type signature: dict:STRING * pathlen:int * pathobjs:STRING*
# * ecvar:int32* -> STRING?
#
# Gets a value by key from a dictionary. Can fail if the "dict" is
# not a valid dictionary.
set f [$m local "tcl.dict.get" STRING?<-STRING,int,STRING*,int*]
params dict keyc keyv ecvar
build {
noalias $dict $keyv $ecvar
nonnull $dict $keyv $ecvar
set interp [$api tclInterp]
my condBr [my eq $keyc $0] $verify $get
label verify:
set dummy [my alloc int "dummy"]
set code [$api Tcl_DictObjSize $interp $dict $dummy]
my condBr [my eq $code $0] $return $notOK
label get:
set n [my sub $keyc $1]
set dict2 [$api TclTraceDictPath $interp $dict $n $keyv $0]
SetValueName $dict2 "dictObj"
my condBr [my nonnull $dict2] $lookup $notOK
label lookup:
set resvar [my alloc STRING "valueVar"]
set key [my load [my getelementptr $keyv [list $n]] "key"]
set result [$api Tcl_DictObjGet $interp $dict2 $key $resvar]
my condBr [my eq $result $0] $OK $fail
label OK:
set value [my load $resvar "value"]
my condBr [my nonnull $value] $return $fail
label return:
set value [my phi [list $dict $value] [list $verify $OK] "value"]
my addReference(STRING) $value
my ret [my just $value]
label fail:
set keyval [$api Tcl_GetString $key]
$api Tcl_SetObjResult $interp \
[$api Tcl_ObjPrintf [my constString \
"key \"%s\" not known in dictionary"] \
$keyval]
$api Tcl_SetErrorCode $interp \
[my constString TCL] [my constString LOOKUP] \
[my constString DICT] $keyval [my null char*]
my br $notOK
label notOK:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.dict.set1 #####
#
# Type signature: dict:STRING * key:STRING * value:STRING
# * ecvar:int32* -> STRING?
#
# Sets a key in a dictionary to map to a value. Can fail if the
# "dict" is not a valid dictionary.
set f [$m local "tcl.dict.set1" STRING?<-STRING,STRING,STRING,int*]
params dict key value ecvar
build {
noalias $ecvar
nonnull $dict $key $value $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjPut $interp $dict $key $value]
my condBr [my eq $result $0] $OK $notOK
label OK:
my addReference(STRING) $dict
my condBr [my shared $value] $exit2 $exit3
label exit3 "exit"
my addReference(STRING) $value
my br $exit2
label exit2 "exit"
my ret [my just $dict]
label notOK:
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.dict.set #####
#
# Type signature: dict:STRING * pathlen:int * pathobjs:STRING*
# * value:STRING * ecvar:int32* -> STRING?
#
# Sets a key (or rather a key path) in a dictionary to map to a value.
# Can fail if the "dict" is not a valid dictionary.
set f [$m local "tcl.dict.set" STRING?<-STRING,int,STRING*,STRING,int*]
params dict pathlen pathobjs value ecvar
build {
noalias $pathobjs $ecvar
nonnull $dict $pathobjs $value $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjPutKeyList $interp $dict $pathlen $pathobjs $value]
my condBr [my eq $result $0] $OK $notOK
label OK:
my addReference(STRING) $dict
my condBr [my shared $value] $exit2 $exit3
label exit3 "exit"
my addReference(STRING) $value
my br $exit2
label exit2 "exit"
my ret [my just $dict]
label notOK:
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.dict.unset1 #####
#
# Type signature: dict:STRING * key:STRING * ecvar:int32* -> STRING?
#
# Removes a key from a dictionary. Can fail if the "dict" is not a
# valid dictionary.
set f [$m local "tcl.dict.unset1" STRING?<-STRING,STRING,int*]
params dict key ecvar
build {
noalias $ecvar
nonnull $dict $key $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjRemove $interp $dict $key]
my condBr [my eq $result $0] $OK $notOK
label OK:
my addReference(STRING) $dict
my ret [my just $dict]
label notOK:
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.dict.unset #####
#
# Type signature: dict:STRING * pathlen:int * pathobjs:STRING*
# * ecvar:int32* -> STRING?
#
# Removes a key (or rather a key path) from a dictionary. Can fail if
# the "dict" is not a valid dictionary.
set f [$m local "tcl.dict.unset" STRING?<-STRING,int,STRING*,int*]
params dict pathlen pathobjs ecvar
build {
noalias $dict $pathobjs $ecvar
nonnull $dict $pathobjs $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set result [$api Tcl_DictObjRemoveKeyList $interp $dict $pathlen $pathobjs]
my condBr [my eq $result $0] $OK $notOK
label OK:
my ret [my just $dict]
label notOK:
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.dict.addIterReference #####
#
# Type signature: iter:DICTITER -> void
#
# Increments the reference count inside a dictionary iteration state.
set f [$m local "tcl.dict.addIterReference" void<-DICTITER]
params iter
build {
nonnull $iter
set ref [my gep $iter 0 DICTFOR.ref]
set rc [my load $ref]
my store [my add $rc $1] $ref
my ret
}
##### Function tcl.dict.iterStart #####
#
# Type signature: dict:STRING * ecvar:int* -> DICTITER?
#
# Starts iterating over a dictionary. The current state of the
# iteration (assuming we don't get an error) is stored inside the
# returned iteration state value.
set f [$m local "tcl.dict.iterStart" DICTITER?<-STRING,int*]
params dict ecvar
build {
noalias $ecvar
nonnull $dict $ecvar
set interp [$api tclInterp]
set iter [$api cknew DICTFOR]
set key [my gep $iter 0 DICTFOR.key]
SetValueName $key "keyPtr"
set value [my gep $iter 0 DICTFOR.value]
SetValueName $value "valuePtr"
set done [my alloc int "done"]
set search [my gep $iter 0 DICTFOR.search]
set code [$api Tcl_DictObjFirst $interp $dict \
$search $key $value $done]
my condBr [my eq $code $0] $ok $failed
label ok:
my storeInStruct $iter DICTFOR.dict $dict
my storeInStruct $iter DICTFOR.ref $0
my storeInStruct $iter DICTFOR.done [my neq [my load $done] $0]
my addReference(STRING) $dict
my Call tcl.dict.addIterReference $iter
my ret [my just $iter]
label failed:
$api ckfree $iter
my store $1 $ecvar
my ret [my nothing DICTITER]
}
##### Function tcl.dict.iterNext #####
#
# Type signature: iter:DICTITER -> DICTITER
#
# Continues iterating over a dictionary. The current state of the
# iteration (assuming we don't get an error) is stored inside the
# returned iteration state value.
set f [$m local "tcl.dict.iterNext" DICTITER<-DICTITER]
params iter
build {
nonnull $iter
my condBr [my dereference $iter 0 DICTFOR.done] $finished $nextStep
label nextStep:
set key [my gep $iter 0 DICTFOR.key]
SetValueName $key "keyPtr"
set value [my gep $iter 0 DICTFOR.value]
SetValueName $value "valuePtr"
set done [my alloc int "done"]
set search [my gep $iter 0 DICTFOR.search]
$api Tcl_DictObjNext $search $key $value $done
my storeInStruct $iter DICTFOR.done [my neq [my load $done] $0]
my br $finished
label finished:
my Call tcl.dict.addIterReference $iter
my ret $iter
}
##### Function tcl.dict.dropIterReference #####
#
# Type signature: iter:DICTITER -> void
#
# Decrements the reference count inside a dictionary iteration state,
# freeing it if the reference count drops to zero.
set f [$m local "tcl.dict.dropIterReference" void<-DICTITER]
params iter
build {
nonnull $iter
set ref [my gep $iter 0 DICTFOR.ref]
set rc [my load $ref]
my store [my sub $rc $1] $ref
my condBr [my gt $rc $1] $done $free
label free:
set search [my gep $iter 0 DICTFOR.search]
$api Tcl_DictObjDone $search
my dropReference [my dereference $iter 0 DICTFOR.dict]
$api ckfree $iter
my ret
label done:
my ret
}
##### Function tcl.dict.dropIterFailReference #####
#
# Type signature: iter:DICTITER? -> void
#
# Decrements the reference count inside a Maybe dictionary iteration
# state, freeing it if the reference count drops to zero.
set f [$m local "tcl.dict.dropIterFailReference" void<-DICTITER?]
params iter
build {
my condBr [my maybe $iter] $nothing $release
label nothing:
my ret
label release:
my Call tcl.dict.dropIterReference [my unmaybe $iter]
my ret
}
##### Function tcl.dict.iterKey #####
#
# Type signature: iter:DICTITER -> STRING
#
# Gets the key for this iteration of the dictionary. If there is no
# key, we get the empty string. Increments it's result refCount.
set f [$m local "tcl.dict.iterKey" STRING<-DICTITER]
params iter
build {
nonnull $iter
my condBr [my dereference $iter 0 DICTFOR.done] $alloc $real
label alloc:
set new [$api Tcl_NewObj]
my br $save
label real:
set obj [my dereference $iter 0 DICTFOR.key]
my br $save
label save:
set obj [my phi [list $obj $new] [list $real $alloc] "obj"]
my addReference(STRING) $obj
my ret $obj
}
##### Function tcl.dict.iterValue #####
#
# Type signature: iter:DICTITER -> STRING
#
# Gets the value for this iteration of the dictionary. If there is no
# value, we get the empty string. Increments it's result refCount.
set f [$m local "tcl.dict.iterValue" STRING<-DICTITER]
params iter
build {
nonnull $iter
my condBr [my dereference $iter 0 DICTFOR.done] $alloc $real
label alloc:
set new [$api Tcl_NewObj]
my br $save
label real:
set obj [my dereference $iter 0 DICTFOR.value]
my br $save
label save:
set obj [my phi [list $obj $new] [list $real $alloc] "obj"]
my addReference(STRING) $obj
my ret $obj
}
##### Function tcl.dict.iterDone #####
#
# Type signature: iter:DICTITER -> ZEROONE
#
# Gets whether this iteration of the dictionary has finished.
set f [$m local "tcl.dict.iterDone" ZEROONE<-DICTITER]
params iter
build {
nonnull $iter
my ret [my dereference $iter 0 DICTFOR.done]
}
##### Function tcl.dict.append #####
#
# Type signature: dict:STRING * key:STRING * value:STRING
# * ecvar:int32* -> STRING?
#
# Appends to value in a dictionary indicated by a key. Can fail if the
# "dict" is not a valid dictionary.
set f [$m local "tcl.dict.append" STRING?<-STRING,STRING,STRING,int*]
params dict key value ecvar
build {
noalias $ecvar
nonnull $dict $key $value $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set valuePtr [my alloc STRING "valuePtr"]
set result [$api Tcl_DictObjGet $interp $dict $key $valuePtr]
my condBr [my eq $result $0] $OK $notOK
label OK:
set dictVal [my load $valuePtr "value.in.dict"]
my condBr [my nonnull $dictVal] $append $set
label set:
$api Tcl_DictObjPut {} $dict $key $value
my br $done
label append:
my condBr [my shared $dictVal] $dupePut $directUpdate
label directUpdate:
$api Tcl_AppendObjToObj $dictVal $value
$api TclInvalidateStringRep $dict
my br $done
label dupePut:
set dictVal2 [$api Tcl_DuplicateObj $dictVal]
$api Tcl_AppendObjToObj $dictVal2 $value
set c [$api Tcl_DictObjPut {} $dict $key $dictVal2]
AddCallAttribute $c 3 nocapture
my br $done
label done:
my addReference(STRING) $dict
my ret [my just $dict]
label notOK:
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.dict.incr #####
#
# Type signature: dict:STRING * key:STRING * value:INT
# * ecvar:int32* -> STRING?
#
# Adds an integer to an integer in a dictionary indicated by a key.
# Can fail if the "dict" is not a valid dictionary or the value
# pointed to is not a valid integer.
set f [$m local "tcl.dict.incr" STRING?<-STRING,STRING,INT,int*]
params dict key value ecvar
build {
noalias $ecvar
nonnull $dict $key $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set valuePtr [my alloc STRING "valuePtr"]
set result [$api Tcl_DictObjGet $interp $dict $key $valuePtr]
my condBr [my eq $result $0] $OK $notOK
label OK:
set dictVal [my load $valuePtr "value.in.dict"]
my condBr [my nonnull $dictVal] $add $set
label set:
set strVal [my stringify(INT) $value "value"]
my br $done
label add:
# TODO: Revisit once we support bignums
set intVar [my alloc int64 "intPtr"]
set result [$api Tcl_GetWideIntFromObj $interp $dictVal $intVar]
my condBr [my eq $result $0] $doAdd $notOK
label doAdd:
set int [my packInt64 [my load $intVar "int"] "int"]
set updatedValue [my add(INT,INT) $int $value "value"]
set addVal [my stringify(INT) $updatedValue "value"]
my br $done
label done:
set resultValue [my phi [list $strVal $addVal] \
[list $set $doAdd] "value"]
# No failure mode at this point: we know we've got a dictionary.
set c [$api Tcl_DictObjPut {} $dict $key $resultValue]
my addReference(STRING) $dict
my ret [my just $dict]
label notOK:
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.dict.lappend #####
#
# Type signature: dict:STRING * key:STRING * value:STRING
# * ecvar:int32* -> STRING?
#
# Appends to list in a dictionary indicated by a key. Can fail if the
# "dict" is not a valid dictionary or the value pointed to is not a
# valid list.
set f [$m local "tcl.dict.lappend" STRING?<-STRING,STRING,STRING,int*]
params dict key value ecvar
build {
noalias $ecvar
nonnull $dict $key $value $ecvar
set interp [$api tclInterp]
set dd [my Dedup dict]
set valuePtr [my alloc STRING "valuePtr"]
set result [$api Tcl_DictObjGet $interp $dict $key $valuePtr]
my condBr [my eq $result $0] $OK $notOK
label OK:
set dictVal [my load $valuePtr "value.in.dict"]
my condBr [my nonnull $dictVal] $append $set
label set:
my store $value $valuePtr
set newlist [$api Tcl_NewListObj $1 $valuePtr]
$api Tcl_DictObjPut {} $dict $key $newlist
my br $done
label append:
my condBr [my shared $dictVal] $dupePut $directUpdate
label directUpdate:
set result [$api Tcl_ListObjAppendElement $interp $dictVal $value]
my condBr [my eq $result $0] $dictUpdateOK $notOK
label dictUpdateOK:
$api TclInvalidateStringRep $dict
my br $done
label dupePut:
set dictVal [$api Tcl_DuplicateObj $dictVal]
set result [$api Tcl_ListObjAppendElement $interp $dictVal $value]
my condBr [my eq $result $0] $dupeUpdateOK $dupeNotOK
label dupeUpdateOK:
set c [$api Tcl_DictObjPut {} $dict $key $dictVal]
AddCallAttribute $c 3 nocapture
my br $done
label done:
my addReference(STRING) $dict
my ret [my just $dict]
label dupeNotOK:
my dropReference $dictVal
my br $notOK
label notOK:
my Call obj.cleanup $dd
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.maptoint #####
#
# Type signature: value:STRING * mapping:STRING * notThere:int -> INT
#
# Quadcode implementation ('maptoint')
#
# Returns the INT looked up in 'mapping' that corresponds to 'value'.
# If the value is absent, returns the 'notThere' value.
set f [$m local "tcl.maptoint" INT<-STRING,Tcl_HashTable*,int]
params value mapping notThere
build {
nonnull $value $mapping
set offset [$api TclFindHashEntry $mapping $value]
SetValueName $offset "offsetPtr"
my condBr [my nonnull $offset] $present $absent
label present:
set offset [$api Tcl_GetHashValue $offset int]
SetValueName $offset "offset"
my ret [my packInt32 $offset]
label absent:
my ret [my packInt32 $notThere]
}
##### Function tcl.concatenate #####
#
# Type signature: len:int * ary:STRING* -> STRING
#
# Quadcode implementation ('concat')
#
# Returns the application of Tcl_ConcatObj() to the given values, so
# much so that it is just a very thin wrapper around that function.
set f [$m local "tcl.concatenate" STRING<-int,STRING*]
params len ary
build {
nonnull $ary
set result [$api Tcl_ConcatObj $len $ary]
my addReference(STRING) $result
my ret $result
}
}
# Builder:StringComparisonFunctions --
#
# Generate the functions that implement the string comparators. Only
# called from StringFunctions method.
#
# Parameters:
# api - The handle of the Tcl API object (currently an instance of the
# Thunk class).
#
# Results:
# None.
method StringComparisonFunctions {api} {
upvar 1 sizeof sizeof 0 0 1 1
##### Function tcl.streq #####
#
# Type signature: value1Ptr:STRING * value2Ptr:STRING -> ZEROONE
#
# Quadcode implementation ('streq')
#
# Returns whether the two string arguments are equal.
set f [$m local "tcl.streq" ZEROONE<-STRING,STRING]
params v1:value1Ptr v2:value2Ptr
build {
nonnull $v1 $v2
my condBr [my eq $v1 $v2] $identical $nexttest
label nexttest:
my condBr [my and [my isByteArray $v1] [my isByteArray $v2]] \
$cmpBA $nexttest2
label nexttest2:
my condBr [my and \
[my isUnicodeString $v1] \
[my isUnicodeString $v2]] \
$cmpUni $cmpUtf
label identical:
my ret [Const true bool]
label different:
my ret [Const false bool]
label cmpBA "byteArrays"
lassign [my GetBytes $v1 "value1"] len ba1
lassign [my GetBytes $v2 "value2"] len2 ba2
my condBr [my eq $len $len2] $cmpBA2 $different
label cmpBA2 "compareByteArrays"
set diff [my memcmp $ba1 $ba2 $len]
my condBr [my eq $diff $0] $identical $different
label cmpUni "unicodeStrings"
set len [$api Tcl_GetCharLength $v1]
my condBr [my eq $len [$api Tcl_GetCharLength $v2]] \
$cmpUni2 $different
label cmpUni2 "compareUnicodeStrings"
# TODO use bytes field if both have it
set u1 [$api Tcl_GetUnicode $v1]
set u2 [$api Tcl_GetUnicode $v2]
set len [my mult $len $sizeof(Tcl_UniChar)]
set diff [my memcmp $u1 $u2 $len]
my condBr [my eq $diff $0] $identical $different
label cmpUtf "UTF8Strings"
lassign [my GetString $v1 "s1"] len s1
lassign [my GetString $v2 "s2"] len2 s2
my condBr [my eq $len $len2] $cmpUtf2 $different
label cmpUtf2 "compareUTF8Strings"
set diff [my memcmp $s1 $s2 $len]
my condBr [my eq $diff $0] $identical $different
}
##### Function tcl.strcmp #####
#
# Type signature: value1Ptr:STRING * value2Ptr:STRING -> int
#
# Quadcode implementation ('strcmp')
#
# Returns the relationship between the two string arguments; -1 if
# 'value1Ptr' precedes in standard ordering, 1 if 'value2Ptr'
# precedes, and 0 if they are equal.
set f [$m local "tcl.strcmp" int<-STRING,STRING]
params v1:value1Ptr v2:value2Ptr
build {
nonnull $v1 $v2
my condBr [my eq $v1 $v2] $identical $nexttest
label nexttest:
my condBr [my isByteArray $v1] $testBA2 $nexttest2
label testBA2:
my condBr [my isByteArray $v2] $cmpBA $nexttest2
label nexttest2:
my condBr [my and \
[my isUnicodeString $v1] \
[my isUnicodeString $v2]] \
$cmpUni $cmpUtf
label identical:
my ret $0
label cmpBA "byteArrays"
lassign [my GetBytes $v1 "value1"] len1 ba1
lassign [my GetBytes $v2 "value2"] len2 ba2
set diffBA [my sub $len1 $len2]
set matchBA [my memcmp $ba1 $ba2 [my min $len1 $len2]]
my br $result
label cmpUni "unicode"
set len1 [$api Tcl_GetCharLength $v1]
set len2 [$api Tcl_GetCharLength $v2]
set diffUni [my sub $len1 $len2]
set matchUni [$api Tcl_UniCharNcmp [$api Tcl_GetUnicode $v1] \
[$api Tcl_GetUnicode $v2] [my min $len1 $len2]]
my br $result
label cmpUtf "UTF8"
set s1 [$api Tcl_GetString $v1]
set s2 [$api Tcl_GetString $v2]
set len1 [$api Tcl_GetCharLength $v1]
set len2 [$api Tcl_GetCharLength $v2]
set diffUtf [my sub $len1 $len2]
set matchUtf [$api TclpUtfNcmp2 $s1 $s2 [my min $len1 $len2]]
my br $result
label result:
set sources [list $cmpBA $cmpUni $cmpUtf]
set match [my phi [list $matchBA $matchUni $matchUtf] $sources]
set diff [my phi [list $diffBA $diffUni $diffUtf] $sources]
my ret [my select [my eq $match $0] $diff $match]
}
##### Function tcl.strmatch #####
#
# Type signature: nocase:INT * pattern:STRING * string:STRING
# -> ZEROONE
#
# Quadcode implementation ('strmatch')
#
# Returns whether the glob pattern in 'pattern' matches 'string'. If
# 'nocase' is non-zero, performs the match case-insensitively.
set f [$m local "tcl.strmatch" ZEROONE<-INT,STRING,STRING]
params nocaseInt:nocase patternObj:pattern stringObj:string
build {
nonnull $patternObj $stringObj
set nocase [my getInt32 $nocaseInt]
my condBr [my isUnicodeString $patternObj] $test2 $ordinary
label test2:
my condBr [my isUnicodeString $stringObj] $unicode $ordinary
# TODO support TclByteArrayMatch (but that needs exposing first)
label ordinary "ordinaryMatch"
set pattern [$api Tcl_GetString $patternObj]
set string [$api Tcl_GetString $stringObj]
set match [$api Tcl_StringCaseMatch $string $pattern $nocase]
my ret [my neq $match $0]
label unicode "unicodeMatch"
lassign [my GetUnicode $patternObj "pattern"] patLen patStr
lassign [my GetUnicode $stringObj "string"] strLen strStr
set match [$api TclUniCharMatch $strStr $strLen $patStr $patLen \
$nocase]
my ret [my neq $match $0]
}
##### Function tcl.regexp #####
#
# Type signature: flags:INT * regexp:STRING * string:STRING
# * errVar:int* -> ZEROONE?
#
# Quadcode implementation ('regexp')
#
# Returns whether the regular expression in 'regexp' matches 'string'
# as a WRAPPED BOOLEAN. The 'flags' control things like whether we are
# matching case-insensitively. If the code fails (generally because of
# a bad regular expression) then the result is a Nothing. The variable
# pointed to by 'errVar' is set to the relevant Tcl result code.
set f [$m local "tcl.regexp" ZEROONE?<-INT,STRING,STRING,int*]
params flags patternObj:regexp stringObj:string errVar:errorCode
build {
noalias $errVar
nonnull $patternObj $stringObj $errVar
set interp [$api tclInterp]
set RE [$api Tcl_GetRegExpFromObj $interp $patternObj \
[my getInt32 $flags]]
my condBr [my nonnull $RE] $exec $err
label exec "re.exec"
set match [$api Tcl_RegExpExecObj $interp $RE $stringObj $0 $0 $0]
my condBr [my ge $match $0] $done $err
label done "re.done"
my store $0 $errVar
my ret [my just [my gt $match $0]]
label err "re.error"
my store $1 $errVar
my ret [my nothing ZEROONE]
}
}
# Builder:CallFrameFunctions --
#
# Generate the functions that implement the callframe handling.
#
# Parameters:
# api - The handle of the Tcl API object (currently an instance of the
# Thunk class).
#
# Results:
# None.
method CallFrameFunctions {api} {
set 0 [Const 0]
set 1 [Const 1]
set f [$m local "tcl.callframe.init" \
void<-CALLFRAME,int,int,STRING*,Proc*]
params frame length objc objv proc
build {
set interp [$api tclInterp]
set rcPtr [my gep $proc 0 Proc.refCount]
my store [my add [my load $rcPtr] $1] $rcPtr
set nsPtr [my dereference [my dereference $proc 0 Proc.cmdPtr] \
0 Command.nsPtr]
$api Tcl_PushCallFrame $interp $frame $nsPtr $1
set varTable [$api cknew TclVarHashTable "varTable"]
set cllen1 [my mult $length [my cast(int) [my sizeof Var]]]
set locals [$api ckalloc $cllen1 Var "locals"]
set cllen2 [my add [my cast(int) [my sizeof LocalCache]] \
[my mult [my sub $length $1] \
[my cast(int) [my sizeof Tcl_Obj*]]]]
set localCache [$api ckalloc $cllen2 LocalCache "localCache"]
my storeInStruct $frame CallFrame.objc $objc
my storeInStruct $frame CallFrame.objv $objv
my storeInStruct $frame CallFrame.procPtr $proc
my storeInStruct $frame CallFrame.varTablePtr $varTable
my storeInStruct $frame CallFrame.numCompiledLocals $length
my storeInStruct $frame CallFrame.compiledLocals $locals
my storeInStruct $frame CallFrame.localCachePtr $localCache
$api TclInitVarHashTable $varTable [my null Namespace*]
my bzero $locals $cllen1
my bzero $localCache $cllen2
my storeInStruct $localCache LocalCache.numVars $length
# No other setup of LocalCache required; LVT just holds
# "temporaries" which are links to real variables in hash table;
# the temporaries are there to keep the real variables in the hash
# table referenced.
# Need to define array of argument objects, required for making
# [info level] work right.
my Warn "tcl.callframe.init not yet finished"; # FIXME
my ret
}
set f [$m local "tcl.callframe.makevar" Var*<-CALLFRAME,int,STRING]
params frame index name
build {
set vars [my dereference $frame 0 CallFrame.varTablePtr]
set varEntry [$api TclCreateHashEntry \
[my gep $vars 0 TclVarHashTable.table] $name]
SetValueName $varEntry varEntry
set var [my Call var.hash.getValue $varEntry]
set lvt [my dereference $frame 0 CallFrame.compiledLocals]
set local [my getelementptr $lvt $index]
# VAR_LINK | VAR_TEMPORARY
my storeInStruct $local Var.flags [Const 0x202]
my storeInStruct $local Var.value [my cast(ptr) $var Tcl_Obj]
set rc [my gep [my cast(ptr) $var VarInHash] 0 VarInHash.refCount]
my store [my add $1 [my load $rc]] $rc
my ret $var
}
set f [$m local "tcl.callframe.clear" void<-CALLFRAME]
params frame
build {
set interp [$api tclInterp]
$api Tcl_PopCallFrame $interp
set proc [my dereference $frame 0 CallFrame.procPtr]
set rcPtr [my gep $proc 0 Proc.refCount]
my store [my sub [my load $rcPtr] $1] $rcPtr
# TODO: ought to theoretically delete the Proc when it has a
# refcount of 0.
# FIXME delete the array of argument objects; CallFrame.objv field
my Warn "tcl.callframe.clear not yet finished"; # FIXME
my ret
}
set f [$m local "tcl.callframe.store" void<-Var*,STRING,STRING?]
params var varName value
build {
set interp [$api tclInterp]
set nv [my null Var*]
set ns [my null STRING]
my condBr [my maybe $value] $doUnset $doSet
label doSet:
set value [my unmaybe $value]
my Call tcl.write.var.ptr $interp $var $nv $varName $ns $value $0
my ret
label doUnset:
my Call tcl.unset.var.ptr $interp $var $nv $varName $ns $0
my ret
}
set f [$m local "tcl.callframe.load" STRING?<-Var*,STRING]
params var varName
build {
set interp [$api tclInterp]
set nv [my null Var*]
set ns [my null STRING]
set value [my Call tcl.read.var.ptr $interp $var $nv $varName $ns $0]
my condBr [my nonnull $value] \
$gotValue $noValue
label gotValue:
my addReference(STRING) $value
my ret [my just $value]
label noValue:
my ret [my nothing STRING]
}
}
# Builder:@apiFunctions --
#
# Generate the quadcode operator implementations that require access to
# the Tcl API to work.
#
# Parameters:
# api - The handle of the Tcl API object (currently an instance of the
# Thunk class).
#
# Results:
# None.
method @apiFunctions {module api} {
my StringifyFunctions $api
my ReferenceFunctions $api
my StringFunctions $api
# Builder:MathException --
#
# Generate one of the standard math exceptions that are produced
# when doing an integer divide by zero or the result of a double
# operation would be a NaN.
#
# Parameters:
# ecvar - The LLVM value reference to the int* where the Tcl
# error code is written.
# args - Tcl strings for words to use in the exception code.
# The final word will be used as the Tcl error message.
#
# Results:
# None.
my closure MathException {ecvar args} {
set interp [$api tclInterp]
set msg [$api obj.constant [lindex $args end]]
SetValueName $msg "exception.message"
set exn [$api obj.constant $args]
SetValueName $exn "exception.code"
$api Tcl_SetObjResult $interp $msg
$api Tcl_SetObjErrorCode $interp $exn
my store [Const 1] $ecvar
return
}
my ErroringMathFunctions
set 0 [Const 0]
set 1 [Const 1]
##### Function tcl.getresult #####
#
# Type signature: void -> STRING
#
# Quadcode implementation ('result')
#
# Returns the current interpreter result.
set f [$module local "tcl.getresult" STRING<-]
build {
set result [$api Tcl_GetObjResult [$api tclInterp]]
SetValueName $result "resultObj"
my addReference(STRING) $result
my ret $result
}
##### Function tcl.getreturnopts #####
#
# Type signature: returnCode:INT -> STRING
#
# Quadcode implementation ('returnOptions')
#
# Returns the return options dictionary. Note that this requires the
# current Tcl result code in order to work correctly.
set f [$module local "tcl.getreturnopts" STRING<-INT]
params value:returnCode
build {
set code [my int.32 $value "code"]
set opts [$api Tcl_GetReturnOptions [$api tclInterp] $code]
SetValueName $opts "optionsObj"
my addReference(STRING) $opts
my ret $opts
}
##### Function tcl.initExceptionOptions #####
#
# Type signature: objPtr:STRING * dictPtr:STRING -> int
#
# Initialises the return options from what we know about an exception.
set f [$module local "tcl.initExceptionOptions" int<-STRING,STRING]
params result:objPtr opts:dictPtr
build {
nonnull $result $opts
set interp [$api tclInterp]
set code [$api Tcl_SetReturnOptions $interp $opts]
my switch $code $other 0 $ok 1 $error
label ok:
my ret $code
label error:
# BEWARE! Must do this in this order, because an error in the
# option dictionary overrides the result (and can be verified by
# test).
$api Tcl_SetObjResult $interp $result
$api Tcl_SetReturnOptions $interp $opts
my ret $code
label other:
$api Tcl_SetObjResult $interp $result
my ret $code
}
##### Function tcl.initExceptionSimple #####
#
# Type signature: message:STRING * errorcode:STRING -> void
#
# Construct a simple exception, with just error message and error code
# list.
set f [$module local "tcl.initExceptionSimple" void<-STRING,STRING]
params message errorcode
build {
nonnull $message $errorcode
set interp [$api tclInterp]
$api Tcl_SetObjResult $interp $message
set field [my gep $interp 0 Tcl_Interp.returnOpts]
set ro [my load $field]
set newOpts [$api Tcl_NewObj]
set key [$api obj.constant "-errorcode"]
$api Tcl_DictObjPut {} $newOpts $key $errorcode
my store $newOpts $field
my addReference(STRING) $newOpts
my condBr [my nonnull $ro] $dropold $testForError
label dropold "swap.dropOld"
my dropReference $ro
my br $testForError
label testForError "test.for.error"
set field [my gep $interp 0 Tcl_Interp.errorInfo]
set ei [my load $field]
my condBr [my nonnull $ei] $clearEI $setEC
label clearEI "error.clearErrorInfo"
my dropReference $ei
my store [my null STRING] $field
my br $setEC
label setEC "error.setErrorCode"
$api Tcl_SetObjErrorCode $interp $errorcode
set field [my gep $interp 0 Tcl_Interp.flags]
my store [my or [my load $field] [Const 0x800]] $field
my ret
}
##### Function tcl.processReturn #####
#
# Type signature: result:STRING * code:int * level:int
# * returnOpts:STRING -> int
#
# Initialises the return options from what we know about an exception.
# Analogous to TclProcessReturn, which isn't exposed.
#
# Note that returnOpts may be NULL; that's equivalent to an empty
# options dictionary, but is special-cased so it is handled more
# efficiently by the optimizer.
set f [$module local "tcl.processReturn" int<-STRING,int,int,STRING]
params result code level returnOpts
build {
nonnull $result
set interp [$api tclInterp]
$api Tcl_SetObjResult $interp $result
set valuePtr [my alloc STRING "valuePtr"]
set field [my gep $interp 0 Tcl_Interp.returnOpts]
set ro [my load $field]
my condBr [my neq $ro $returnOpts] $swap $testForError
label swap:
my condBr [my nonnull $ro] $swapdropold $swapinnew
label swapdropold "swap.dropOld"
my dropReference $ro
my condBr [my nonnull $returnOpts] $swapinnew $totallyNew
label totallyNew "swap.totallyNew"
set newOpts [$api Tcl_NewObj]
my store $newOpts $field
my addReference(STRING) $newOpts
my br $testForError
label swapinnew "swap.inNew"
my store $returnOpts $field
my addReference(STRING) $returnOpts
my br $testForError
label testForError "test.for.error"
my condBr [my eq $code $1] $error $testForReturn
label error:
set field [my gep $interp 0 Tcl_Interp.errorInfo]
set ei [my load $field]
my condBr [my nonnull $ei] $clearEI $getEI
label clearEI "error.clearErrorInfo"
my dropReference $ei
my store [my null STRING] $field
my br $getEI
label getEI "error.getErrorInfo"
my store [my null STRING] $valuePtr
my condBr [my nonnull $returnOpts] $testEI $getES
label testEI "error.testHaveErrorInfo"
$api Tcl_DictObjGet {} $returnOpts \
[$api obj.constant "-errorinfo"] $valuePtr
set value [my load $valuePtr "errorInfo"]
my condBr [my nonnull $value] $installEI $getES
label installEI "error.installErrorInfo"
set infoLen [my alloc int "infoLen"]
$api Tcl_GetStringFromObj $value $infoLen
my condBr [my neq [my load $infoLen] $0] $installEI2 $getES
label installEI2 "error.setErrorInfo"
my store $value $field
my addReference(STRING) $value
set field [my gep $interp 0 Tcl_Interp.flags]
my store [my or [my load $field] [Const 4]] $field
my br $getES
label getES "error.getErrorStack"
my condBr [my nonnull $returnOpts] $testES $getEC
label testES "error.testHaveErrorStack"
$api Tcl_DictObjGet {} $returnOpts \
[$api obj.constant "-errorstack"] $valuePtr
set value [my load $valuePtr "errorStack"]
my condBr [my nonnull $value] $installES $getEC
label installES "error.installErrorStack"
set field [my gep $interp 0 Tcl_Interp.errorStack]
my condBr [my shared [my load $field]] $dedupES $getESElems
label dedupES "error.deduplicateErrorStack"
set oldobj [my load $field]
set newobj [$api Tcl_DuplicateObj $oldobj]
my dropReference $oldobj
my addReference(STRING) $newobj
my store $newobj $field
my br $getESElems
label getESElems "error.getErrorStackElements"
set objcPtr [my alloc int]
set objvPtr [my alloc STRING*]
my condBr [my neq $0 \
[$api Tcl_ListObjGetElements $interp $value $objcPtr $objvPtr]]\
$notList $setES
label notList "error.getErrorStackElements.notList"
my ret $1
label setES "error.setErrorStack"
my store $0 [my gep $interp 0 Tcl_Interp.resetErrorStack]
set lenPtr [my alloc int]
set es [my load $field]
$api Tcl_ListObjLength $interp $es $lenPtr
$api Tcl_ListObjReplace $interp \
$es $0 [my load $lenPtr "len"] \
[my load $objcPtr "objc"] [my load $objvPtr "objv"]
my br $getEC
label getEC "error.getErrorCode"
my condBr [my nonnull $returnOpts] $testEC $installNone
label testEC "error.testHaveErrorCode"
$api Tcl_DictObjGet {} $returnOpts \
[$api obj.constant "-errorcode"] $valuePtr
set value [my load $valuePtr "errorCode"]
my condBr [my nonnull $value] $installEC $installNone
label installEC "error.installErrorCode"
$api Tcl_SetObjErrorCode $interp $value
my br $getEL
label installNone "error.installNONE"
$api Tcl_SetErrorCode $interp [my constString NONE] [my null char*]
my br $getEL
label getEL "error.getErrorLine"
my condBr [my nonnull $returnOpts] $testEL $testForReturn
label testEL "error.testHaveErrorInfo"
$api Tcl_DictObjGet {} $returnOpts \
[$api obj.constant "-errorline"] $valuePtr
set value [my load $valuePtr "errorLine"]
my condBr [my nonnull $value] $installEL $testForReturn
label installEL "error.installErrorLine"
$api Tcl_GetIntFromObj {} $value \
[my gep $interp 0 Tcl_Interp.errorLine]
my br $testForReturn
label testForReturn "test.for.return"
my condBr [my neq $level $0] $processReturn $retestForError
label processReturn "return.process"
my storeInStruct $interp Tcl_Interp.returnLevel $level
my storeInStruct $interp Tcl_Interp.returnCode $code
my ret [Const 2]; # TCL_RETURN
label retestForError "test.for.error"
my condBr [my eq $code $1] $addFlag $done
label addFlag "error.addFlag"
set field [my gep $interp 0 Tcl_Interp.flags]
my store [my or [my load $field] [Const 0x800]] $field
my br $done
label done:
my ret $code
}
##### Function tcl.booleanTest #####
#
# Type signature: objPtr:Tcl_Obj* -> ZEROONE
#
# Part of quadcode implementation ('isBoolean')
#
# Returns whether the string 'objPtr' is a boolean value.
set f [$m local "tcl.booleanTest" ZEROONE<-Tcl_Obj*]
params objPtr
build {
nonnull $objPtr
set NULL [my null Tcl_Interp*]
set code [my setFromAny [$api tclBooleanType] $NULL $objPtr]
my ret [my eq $code $0]
}
##### Function tcl.invoke.command #####
#
# Type signature: objc:int * objv:STRING* * ecvar:int* -> STRING?
#
# Calls the Tcl interpreter to invoke a Tcl command, and packs the
# result into a STRING FAIL.
set f [$module local "tcl.invoke.command" STRING?<-int,STRING*,int*]
params objc objv ecvar
build {
noalias $objv $ecvar
nonnull $objv $ecvar
set interp [$api tclInterp]
set code [$api Tcl_EvalObjv $interp $objc $objv $0]
my condBr [my eq $code $0] $ok $fail
label ok:
set result [$api Tcl_GetObjResult $interp]
my addReference(STRING) $result
my ret [my just $result]
label fail:
my store $code $ecvar
my ret [my nothing STRING]
}
##### Function tcl.existsOrError #####
#
# Type signature: exists:int1 * message:STRING * ecvar:int* -> int1
#
# Conditionally generates an error about a non-existing variable.
# Generated like this to avoid introducing extra basic blocks at the
# pre-optimized LLVM level.
set f [$module local "tcl.existsOrError" int1<-int1,STRING,STRING,int*]
params exists message exception ecvar
build {
noalias $message $ecvar
nonnull $message $exception $ecvar
my condBr $exists $doError $done
label doError:
my initException $exception $message $ecvar
my br $done
label done:
my ret $exists
}
##### Function tcl.not.string #####
#
# Type signature: value:STRING * ecvar:int* -> ZEROONE?
#
# Quadcode implementation ('not').
#
# Logical negation of 'value'.
set f [$m local "tcl.not.string" ZEROONE?<-STRING,int*]
params value ecvar
build {
noalias $ecvar
nonnull $value $ecvar
set interp [$api tclInterp]
set bvar [my alloc int]
set code [$api Tcl_GetBooleanFromObj $interp $value $bvar]
my condBr [my eq $code [Const 0]] $ok $fail
label fail:
my store $code $ecvar
my ret [my nothing ZEROONE]
label ok:
my ret [my just [my neq [my load $bvar "bool"] [Const 1]]]
}
my @variableFunctions $api
my @numericConverterFunctions $api
##### Function: tcl.resolveCmd #####
#
# Type signature: cmdName:STRING -> STRING
#
# Quadcode implementation('resolveCmd')
#
# Returns either the resolved name of the command or an empty
# string if the command cannot be resolved.
set f [$m local "tcl.resolveCmd" STRING<-STRING]
params cmdName
build {
nonnull $cmdName
set interp [$api tclInterp]
set result [$api Tcl_NewObj]
set cmdPtr [$api Tcl_GetCommandFromObj $interp $cmdName]
my condBr [my nonnull $cmdPtr] $resolved $notResolved
label resolved:
$api Tcl_GetCommandFullName $interp $cmdPtr $result
my br $notResolved
label notResolved:
my addReference(STRING) $result
my ret $result
}
##### Function: tcl.originCmd #####
#
# Type signature: cmdName:STRING ecvar:int32* -> STRING
#
# Quadcode implementation('resolveCmd')
#
# Returns either the resolved name of the command or an empty
# string if the command cannot be resolved.
set f [$m local "tcl.originCmd" STRING?<-STRING,int*]
params cmdName ecvar
build {
nonnull $cmdName $ecvar
noalias $ecvar
set interp [$api tclInterp]
set result [$api Tcl_NewObj]
set cmdPtr [$api Tcl_GetCommandFromObj $interp $cmdName]
my condBr [my nonnull $cmdPtr] $resolved $notResolved
label resolved:
set origCmdPtr [$api TclGetOriginalCommand $cmdPtr]
my condBr [my nonnull $origCmdPtr] $aliased $notAliased
label aliased:
my br $done
label notAliased:
my br $done
label done:
set finalCmdPtr [my phi [list $origCmdPtr $cmdPtr] \
[list $aliased $notAliased]]
$api Tcl_GetCommandFullName $interp $finalCmdPtr $result
my addReference(STRING) $result
my ret [my just $result]
label notResolved:
my dropReference(STRING) $result
$api Tcl_SetObjResult $interp \
[$api Tcl_ObjPrintf \
[my constString "invalid command name \"%s\""] \
[$api Tcl_GetString $cmdName]]
$api Tcl_SetErrorCode $interp \
[my constString TCL] [my constString LOOKUP] \
[my constString COMMAND] [$api Tcl_GetString $cmdName] \
[my null char*]
my store $1 $ecvar
my ret [my nothing STRING]
}
my CallFrameFunctions $api
}
# Builder:@variableFunctions --
#
# Generate the quadcode operator implementations that access Tcl
# variables.
#
# Parameters:
# api - The handle of the Tcl API object (currently an instance of the
# Thunk class).
#
# Results:
# None.
method @variableFunctions {api} {
set 0 [Const 0]
set 1 [Const 1]
set ARRAY [Const 0x1]
set LINK [Const 0x2]
set ARRAY_OR_LINK [Const 0x3]
set NSGLBL [Const [expr {0x1 | 0x2}]]
set APPEND_VALUE [Const 0x04]
set IN_HASHTABLE [Const 0x04]
set LIST_ELEMENT [Const 0x08]
set DEAD_HASH [Const 0x8]
set TRACED_READS [Const 0x10]
set TRACED_WRITES [Const 0x20]
set TRACED_UNSETS [Const 0x40]
set NAMESPACE_VAR [Const 0x80]
set LEAVE_ERR_MSG [Const 0x200]
set TRACED_ARRAY [Const 0x800]
set TRACED_ALL [Const 0x870]
set ARRAY_ELEMENT [Const 0x1000]
set TRACE_ACTIVE [Const 0x2000]
set SEARCH_ACTIVE [Const 0x4000]
set ALL_HASH [Const 0x108c]
##### Function tcl.getornull #####
#
# Convenience helper, that converts a NULL Tcl_Obj* to a NULL char*,
# and otherwise returns the string content of the Tcl_Obj*.
set f [$m local tcl.getornull char*<-Tcl_Obj*]
params objPtr
build {
my condBr [my nonnull $objPtr] $realObj $nullObj
label nullObj:
my ret [my null char*]
label realObj:
my ret [$api Tcl_GetString $objPtr]
}
##### Function var.value #####
#
# Get the value stored in a Tcl variable
set f [$m local var.value Tcl_Obj*<-Var* readonly]
params varPtr
build {
nonnull $varPtr
my ret [my dereference $varPtr 0 Var.value]
}
##### Function var.defined #####
#
# Test if the Tcl variable has a value.
set f [$m local var.defined int1<-Var* readonly]
params varPtr
build {
nonnull $varPtr
my ret [my nonnull [my Call var.value $varPtr]]
}
##### Function var.value.set #####
#
# Set the value stored in a Tcl variable
set f [$m local var.value.set void<-Var*,Tcl_Obj*]
params varPtr valuePtr
build {
nonnull $varPtr
set ptr [my gep $varPtr 0 Var.value]
my store $valuePtr $ptr
my ret
}
##### Function var.value.set.undefined #####
#
# Mark a variable as being undefined.
set f [$m local var.value.set.undefined void<-Var*]
params varPtr
build {
nonnull $varPtr
set ref [my gep $varPtr 0 Var.flags]
my store [my and [my load $ref] [my not $ARRAY_OR_LINK]] $ref
my store [my null Tcl_Obj*] [my gep $varPtr 0 Var.value]
my ret
}
##### Function var.table #####
#
# Get the variable lined to from a Tcl variable
set f [$m local var.table TclVarHashTable*<-Var* readonly]
params varPtr
build {
nonnull $varPtr
set value [my dereference $varPtr 0 Var.value]
my ret [my cast(ptr) $value TclVarHashTable "table"]
}
##### Function var.link #####
#
# Get the variable lined to from a Tcl variable
set f [$m local var.link Var*<-Var* readonly]
params varPtr
build {
nonnull $varPtr
set value [my dereference $varPtr 0 Var.value]
my ret [my cast(ptr) $value Var "link"]
}
##### Function var.flag #####
#
# Test if any of the given flag bits are set on a Tcl variable
set f [$m local var.flag int1<-Var*,int readonly]
params varPtr flag
build {
nonnull $varPtr
set flags [my dereference $varPtr 0 Var.flags]
my ret [my neq [my and $flags $flag] $0]
}
##### Function var.flag.set #####
#
# Set the given flag bits on a Tcl variable
set f [$m local var.flag.set void<-Var*,int]
params varPtr flag
build {
nonnull $varPtr
set ref [my gep $varPtr 0 Var.flags]
my store [my or [my load $ref] $flag] $ref
my ret
}
##### Function var.flag.clear #####
#
# Clear the given flag bits on a Tcl variable
set f [$m local var.flag.clear void<-Var*,int]
params varPtr flag
build {
nonnull $varPtr
set ref [my gep $varPtr 0 Var.flags]
my store [my and [my load $ref] [my not $flag]] $ref
my ret
}
##### Function var.isScalar #####
#
# Test if a Tcl variable is a scalar (not array or link)
set f [$m local var.isScalar int1<-Var*]
params varPtr
build {
nonnull $varPtr
my ret [my not [my Call var.flag $varPtr $ARRAY_OR_LINK]]
}
##### Function var.isArray #####
#
# Test if a Tcl variable is an array
set f [$m local var.isArray int1<-Var*]
params varPtr
build {
nonnull $varPtr
my ret [my Call var.flag $varPtr $ARRAY]
}
##### Function var.isLink #####
#
# Test if a Tcl variable is a link to another variable
set f [$m local var.isLink int1<-Var*]
params varPtr
build {
nonnull $varPtr
my ret [my Call var.flag $varPtr $LINK]
}
##### Function var.isArrayElement #####
#
# Test if a Tcl variable is an array element
set f [$m local var.isArrayElement int1<-Var*]
params varPtr
build {
nonnull $varPtr
my ret [my Call var.flag $varPtr $ARRAY_ELEMENT]
}
##### Function var.hasSearch #####
#
# Test if a Tcl variable has an array search running over it
set f [$m local var.hasSearch int1<-Var*]
params varPtr
build {
nonnull $varPtr
my ret [my Call var.flag $varPtr $SEARCH_ACTIVE]
}
##### Function var.isTraced #####
#
# Test if a Tcl variable is traced at all
set f [$m local var.isTraced int1<-Var*]
params varPtr
build {
nonnull $varPtr
my ret [my Call var.flag $varPtr $TRACED_ALL]
}
##### Function var.isTraced.read #####
#
# Test if a Tcl variable has read traces
set f [$m local var.isTraced.read int1<-Var*]
params varPtr
build {
nonnull $varPtr
my ret [my Call var.flag $varPtr $TRACED_READS]
}
##### Function var.isTraced.write #####
#
# Test if a Tcl variable has write traces
set f [$m local var.isTraced.write int1<-Var*]
params varPtr
build {
nonnull $varPtr
my ret [my Call var.flag $varPtr $TRACED_WRITES]
}
##### Function var.isTraced.unset #####
#
# Test if a Tcl variable has unset traces
set f [$m local var.isTraced.unset int1<-Var*]
params varPtr
build {
nonnull $varPtr
my ret [my Call var.flag $varPtr $TRACED_UNSETS]
}
##### Function var.isTraced.array #####
#
# Test if a Tcl array has whole-array-level traces
set f [$m local var.isTraced.array int1<-Var*]
params varPtr
build {
nonnull $varPtr
my ret [my Call var.flag $varPtr $TRACED_ARRAY]
}
##### Function var.isInHash #####
#
# Test if a Tcl variable is stored in a hash table
set f [$m local var.isInHash int1<-Var*]
params varPtr
build {
nonnull $varPtr
my ret [my Call var.flag $varPtr $IN_HASHTABLE]
}
##### Function var.hash.refCount #####
#
# Get a pointer to the reference count for a variable in a hash table.
# MUST ONLY BE CALLED IF THE VARIABLE IS IN A HASH.
set f [$m local var.hash.refCount int*<-Var* readonly]
params varPtr
build {
nonnull $varPtr
set varPtr [my cast(ptr) $varPtr VarInHash "varPtr"]
my ret [my gep $varPtr 0 VarInHash.refCount]
}
##### Function var.hash.invalidateEntry #####
#
# Mark a variable in a hash table as being invalid. MUST ONLY BE
# CALLED IF THE VARIABLE IS IN A HASH.
set f [$m local var.hash.invalidateEntry void<-Var*]
params varPtr
build {
nonnull $varPtr
my Call var.flag.set $varPtr $DEAD_HASH
my ret
}
##### Function var.hash.clearNamespaceVar #####
#
# Mark a variable in a namespace as no longer being so. MUST ONLY BE
# CALLED IF THE VARIABLE IS IN A HASH.
set f [$m local var.clearNamespaceVar void<-Var*]
params varPtr
build {
my condBr [my Call var.flag $varPtr $NAMESPACE_VAR] \
$2 $done
label 2:
my Call var.flag.clear $varPtr $NAMESPACE_VAR
my condBr [my Call var.isInHash $varPtr] \
$3 $done
label 3:
set ref [my call ${var.hash.refCount} $varPtr]
my store [my sub [my load $ref] $1] $ref
my br $done
label done:
my ret
}
##### Function var.hash.getKey #####
#
# Get a pointer to the key of an element of a hash table. MUST ONLY BE
# CALLED IF THE VARIABLE IS IN A HASH.
set f [$m local var.hash.getKey Tcl_Obj*<-Var* readonly]
params varPtr
build {
nonnull $varPtr
set var [my cast(ptr) $varPtr VarInHash "varPtr"]
set entry [my gep $var 0 VarInHash.entry]
set key [my dereference $entry 0 Tcl_HashEntry.key]
my ret [my cast(ptr) $key Tcl_Obj "objPtr"]
}
##### Function var.hash.getValue #####
#
# Get a pointer to the variable in a hash table from its hash entry.
# MUST ONLY BE CALLED IF THE VARIABLE IS IN A HASH.
set f [$m local var.hash.getValue Var*<-Tcl_HashEntry* readonly]
params hPtr
build {
nonnull $hPtr
set ptr [my cast(ptr) $hPtr char "ptr"]
set offset [my neg [my offsetof VarInHash entry]]
set ptr [my getelementptr $ptr [list $offset] "ptr"]
my ret [my cast(ptr) $ptr Var "var"]
}
##### Function var.hash.delete #####
#
# Delete a hash table that is inside a variable (i.e., where that
# variable is an array). MUST ONLY BE CALLED IF THE VARIABLE IS AN
# ARRAY AND IF THE CONTENTS HAVE BEEN DELETED.
set f [$m local var.hash.delete void<-Var*]
params varPtr
build {
nonnull $varPtr
set tablePtr [my Call var.table $varPtr]
set table [my gep $tablePtr 0 TclVarHashTable.table]
$api Tcl_DeleteHashTable $table
$api ckfree $tablePtr
my ret
}
##### Function var.hash.firstVar #####
#
# Get a pointer to the first variable in a hash table. MUST ONLY BE
# CALLED IF THE VARIABLE IS IN A HASH.
set f [$m local var.hash.firstVar Var*<-TclVarHashTable*,Tcl_HashSearch*]
params tablePtr searchPtr
build {
nonnull $tablePtr $searchPtr
set table [my gep $tablePtr 0 TclVarHashTable.table]
set hPtr [$api Tcl_FirstHashEntry $table $searchPtr]
SetValueName $hPtr "hPtr"
my condBr [my nonnull $hPtr] $yes $no
label yes:
my ret [my Call var.hash.getValue $hPtr]
label no:
my ret [my null Var*]
}
##### Function var.hash.nextVar #####
#
# Get a pointer to the next variable in a hash table. MUST ONLY BE
# CALLED IF THE VARIABLE IS IN A HASH.
set f [$m local var.hash.nextVar Var*<-Tcl_HashSearch*]
params searchPtr
build {
nonnull $searchPtr
set hPtr [$api Tcl_NextHashEntry $searchPtr]
SetValueName $hPtr "hPtr"
my condBr [my nonnull $hPtr] $yes $no
label yes:
my ret [my Call var.hash.getValue $hPtr]
label no:
my ret [my null Var*]
}
##### Function var.isDeadHash #####
#
# Test if a Tcl variable is a dead member of a hash table
set f [$m local var.isDeadHash int1<-Var* readonly]
params varPtr
build {
nonnull $varPtr
my ret [my Call var.flag $varPtr $DEAD_HASH]
}
##### Function var.readerr #####
#
# Support function for tcl.read.var.ptr
set f [$m local var.readerr char*<-Var*,Var* readonly]
params varPtr arrayPtr
build {
nonnull $varPtr
my condBr [my and \
[my not [my Call var.defined $varPtr]] \
[my nonnull $arrayPtr]] \
$testDefinedArray $testArray
label testDefinedArray:
my condBr [my Call var.defined $arrayPtr] \
$noSuchElement $testArray
label testArray:
my condBr [my Call var.flag $varPtr $1] \
$isArray $noSuchVar
label noSuchElement:
my ret [my constString "no such element in array" "noSuchElement"]
label isArray:
my ret [my constString "variable is array" "isArray"]
label noSuchVar:
my ret [my constString "no such variable" "noSuchVar"]
}
##### Function tcl.read.var.ptr #####
#
# Replica of TclPtrGetVar, except without index parameter.
set f [$m local tcl.read.var.ptr \
Tcl_Obj*<-Tcl_Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,int]
params interp varPtr arrayPtr part1Ptr part2Ptr flags
build {
nonnull $interp $varPtr $part1Ptr
my condBr [my expect [my Call var.isTraced.read $varPtr] false] \
$callTraces $test2
label test2:
my condBr [my nonnull $arrayPtr] $test3 $testDirect
label test3:
my condBr [my expect [my Call var.isTraced.read $arrayPtr] false] \
$callTraces $testDirect
label callTraces:
set code [$api TclCallVarTraces $interp $arrayPtr $varPtr \
[$api Tcl_GetString $part1Ptr] \
[my Call tcl.getornull $part2Ptr] \
[my or [my and $flags $NSGLBL] $TRACED_READS] \
[my and $flags $LEAVE_ERR_MSG]]
my condBr [my expect [my eq $code $0] true] \
$testDirect $errorReturn
label testDirect:
my condBr [my and \
[my expect [my Call var.isScalar $varPtr] true] \
[my expect [my Call var.defined $varPtr] true]] \
$direct $readFail
label direct:
my ret [my Call var.value $varPtr]
label readFail:
my condBr [my eq [my and $flags $LEAVE_ERR_MSG] $0] \
$errorReturn $generateError
label generateError "generate.error"
set msg [my Call var.readerr $varPtr $arrayPtr]
SetValueName $msg "msg"
$api TclVarErrMsg $interp [$api Tcl_GetString $part1Ptr] \
[my Call tcl.getornull $part2Ptr] \
[my constString "read"] $msg
my br $errorReturn
label errorReturn:
$api Tcl_SetObjErrorCode $interp \
[$api obj.constant {TCL READ VARNAME}]
my condBr [my Call var.defined $varPtr] \
$cleanupErrorReturn $doneError
label cleanupErrorReturn:
$api TclCleanupVar $varPtr $arrayPtr
my br $doneError
label doneError:
my ret [my null Tcl_Obj*]
}
##### Function set.by.append.element #####
#
# Helper for tcl.write.var.ptr
set f [$m local set.by.append.element \
int1<-Tcl_Interp*,Var*,Tcl_Obj*,Tcl_Obj*]
params interp var oldValue newValue
build {
my condBr [my nonnull $oldValue] \
$update $initial
label initial:
set vp1 [$api Tcl_NewObj]
SetValueName $vp1 "oldValue"
my Call var.value.set $var $vp1
$api Tcl_IncrRefCount $vp1
my br $append
label update:
my condBr [my shared $oldValue] \
$unshare $append
label unshare:
set vp2 [$api Tcl_DuplicateObj $oldValue]
SetValueName $vp2 "oldValue"
my Call var.value.set $var $vp2
$api Tcl_DecrRefCount $oldValue
$api Tcl_IncrRefCount $vp2
my br $append
label append:
set origins [list $initial $unshare $update]
set vp [my phi [list $vp1 $vp2 $oldValue] $origins "oldValue"]
set result [$api Tcl_ListObjAppendElement $interp $vp $newValue]
my ret [my eq $result $0]
}
##### Function set.copy.continuations #####
#
# Helper for tcl.write.var.ptr; TclContinuationsCopy by another name
set f [$m local set.copy.continuations void<-Tcl_Obj*,Tcl_Obj*]
params to from
build {
# FIXME: Cannot make this work from here! Requires access to
# internal variables of tclObj.c.
my ret
}
##### Function set.by.append.string #####
#
# Helper for tcl.write.var.ptr
set f [$m local set.by.append.string void<-Var*,Tcl_Obj*,Tcl_Obj*]
params var oldValue newValue
build {
# We append newValuePtr's bytes but don't change its ref count.
my condBr [my nonnull $oldValue] \
$update $initial
label initial:
my Call var.value.set $var $newValue
$api Tcl_IncrRefCount $newValue
my br $done
label update:
my condBr [my shared $oldValue] \
$unshare $append
label unshare:
set vp1 [$api Tcl_DuplicateObj $oldValue]
SetValueName $vp1 "oldValue"
my Call var.value.set $var $vp1
my Call set.copy.continuations $vp1 $oldValue
$api Tcl_DecrRefCount $oldValue
$api Tcl_IncrRefCount $vp1
my br $append
label append:
set origins [list $unshare $update]
set vp [my phi [list $vp1 $oldValue] $origins "oldValue"]
$api Tcl_AppendObjToObj $vp $newValue
my condBr [my eq [my refCount $newValue] $0] \
$dropRef $done
label dropRef "dropReference"
$api Tcl_DecrRefCount $newValue
my br $done
label done:
my ret
}
##### Function set.direct #####
#
# Helper for tcl.write.var.ptr
set f [$m local set.direct void<-Var*,Tcl_Obj*,Tcl_Obj*]
params var oldValue newValue
build {
my condBr [my eq $newValue $oldValue] \
$done $replace
label replace:
# In this case we are replacing the value, so we don't need to do
# more than swap the objects.
my Call var.value.set $var $newValue
$api Tcl_IncrRefCount $newValue
my condBr [my nonnull $oldValue] \
$dropRef $done
label dropRef "dropReference"
$api Tcl_DecrRefCount $oldValue
my br $done
label done:
my ret
}
##### Function tcl.write.var.ptr #####
#
# Replica of TclPtrSetVar, except without index parameter.
set f [$m local tcl.write.var.ptr \
Tcl_Obj*<-Tcl_Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,Tcl_Obj*,int]
params interp varPtr arrayPtr part1Ptr part2Ptr newValuePtr flags
build {
nonnull $interp $varPtr $part1Ptr $newValuePtr
set nullResultPtr [my null Tcl_Obj*]
set cleanupOnEarlyError \
[my eq [my refCount $newValuePtr] $0 "cleanupOnEarlyError"]
# If the variable is in a hashtable and its hPtr field is NULL,
# then we may have an upvar to an array element where the array
# was deleted or an upvar to a namespace variable whose namespace
# was deleted. Generate an error (allowing the variable to be
# reset would screw up our storage allocation and is meaningless
# anyway).
my condBr [my expect [my Call var.isDeadHash $varPtr] false] \
$deadHash $test2
# It's an error to try to set an array variable itself.
label test2:
my condBr [my expect [my Call var.isArray $varPtr] false] \
$setArray $test3
# Invoke any read traces that have been set for the variable if it
# is requested. This was done for INST_LAPPEND_* but that was
# inconsistent with the non-bc instruction, and would cause
# failures trying to lappend to any non-existing ::env var, which
# is inconsistent with documented behavior. [Bug #3057639].
label test3:
my condBr [my eq [my and $flags $TRACED_READS] $0] \
$doWrite $test4
label test4:
my condBr [my expect [my Call var.isTraced.read $varPtr] false] \
$callReadTraces $test5
label test5:
my condBr [my nonnull $arrayPtr] $test6 $doWrite
label test6:
my condBr [my expect [my Call var.isTraced.read $arrayPtr] false] \
$callReadTraces $doWrite
label callReadTraces:
set code [$api TclCallVarTraces $interp $arrayPtr $varPtr \
[$api Tcl_GetString $part1Ptr] \
[my Call tcl.getornull $part2Ptr] \
$TRACED_READS [my and $flags $LEAVE_ERR_MSG]]
my condBr [my expect [my eq $code $0] true] $doWrite $earlyError
# Set the variable's new value. If appending, append the new value
# to the variable, either as a list element or as a string. Also,
# if appending, then if the variable's old value is unshared we
# can modify it directly, otherwise we must create a new copy to
# modify: this is "copy on write".
label doWrite:
set oldValuePtr [my Call var.value $varPtr]
SetValueName $oldValuePtr "oldValuePtr"
my condBr [my and [my neq [my and $flags $LIST_ELEMENT] $0] \
[my eq [my and $flags $APPEND_VALUE] $0]] \
$clearValue $checkAppend
label clearValue:
my Call var.value.set $varPtr [my null Tcl_Obj*]
my br $checkAppend
label checkAppend:
my condBr [my neq [my and $flags [Const [expr {0x4|0x8}]]] $0] \
$setByAppend $setDirect
label setByAppend "set.by.append"
my condBr [my neq [my and $flags $LIST_ELEMENT] $0] \
$setByAppendElement $setByAppendString
label setByAppendElement "set.by.append.element"
my condBr [my Call set.by.append.element $interp $varPtr \
$oldValuePtr $newValuePtr] \
$testWriteTraces $earlyError
label setByAppendString "set.by.append.string"
my Call set.by.append.string $varPtr $oldValuePtr $newValuePtr
my br $testWriteTraces
label setDirect "set.direct"
my Call set.direct $varPtr $oldValuePtr $newValuePtr
my br $testWriteTraces
# Invoke any write traces for the variable.
label testWriteTraces:
my condBr [my Call var.isTraced.write $varPtr] \
$callWriteTraces $test7
label test7:
my condBr [my nonnull $arrayPtr] \
$test8 $testFastReturn
label test8:
my condBr [my Call var.isTraced.write $arrayPtr] \
$callWriteTraces $testFastReturn
label callWriteTraces:
set code [$api TclCallVarTraces $interp $arrayPtr $varPtr \
[$api Tcl_GetString $part1Ptr] \
[my Call tcl.getornull $part2Ptr] \
[my or [my and $flags $NSGLBL] $TRACED_WRITES] \
[my and $flags $LEAVE_ERR_MSG]]
my condBr [my expect [my eq $code $0] true] \
$testFastReturn $cleanup
# Return the variable's value unless the variable was changed in
# some gross way by a trace (e.g. it was unset and then recreated
# as an array).
label testFastReturn:
my condBr [my expect [my Call var.isScalar $varPtr] true] \
$test9 $slowReturn
label test9:
my condBr [my expect [my Call var.defined $varPtr] true] \
$fastReturn $slowReturn
label fastReturn:
my ret [my Call var.value $varPtr]
# A trace changed the value in some gross way. Return an empty
# string object.
label slowReturn:
set resultPtr [my dereference $interp 0 Tcl_Interp.emptyObjPtr]
my br $cleanup
# Report problems when a variable is in the process of being
# deleted or when it is really an array.
label deadHash:
my condBr [my eq [my and $flags $LEAVE_ERR_MSG] $0] \
$earlyError $test10
label test10:
my condBr [my Call var.isArrayElement $varPtr] \
$deadHashElem $deadHashVar
label deadHashElem "deadHash.danglingElement"
set msg1 [my constString "upvar refers to element in deleted array" "danglingElement"]
$api Tcl_SetObjErrorCode $interp \
[$api obj.constant {TCL LOOKUP ELEMENT}]
my br $reportError
label deadHashVar "deadHash.danglingVariable"
set msg2 [my constString "upvar refers to variable in deleted namespace" "danglingVar"]
$api Tcl_SetObjErrorCode $interp \
[$api obj.constant {TCL LOOKUP VARNAME}]
my br $reportError
label setArray:
my condBr [my eq [my and $flags $LEAVE_ERR_MSG] $0] \
$earlyError $setArrayError
label setArrayError "setArray.error"
set msg3 [my constString "variable is array" "isArray"]
$api Tcl_SetObjErrorCode $interp \
[$api obj.constant {TCL WRITE ARRAY}]
my br $reportError
label reportError:
set origins [list $deadHashElem $deadHashVar $setArrayError]
set msg [my phi [list $msg1 $msg2 $msg3] $origins "msg"]
$api TclVarErrMsg $interp [$api Tcl_GetString $part1Ptr] \
[my Call tcl.getornull $part2Ptr] \
[my constString "set"] $msg
my br $earlyError
# Standard route for reporting problems prior to the set actually
# happening.
label earlyError:
my condBr $cleanupOnEarlyError \
$earlyErrorDropRef $earlyErrorDone
label earlyErrorDropRef "earlyError.dropReference"
$api Tcl_DecrRefCount $newValuePtr
my br $earlyErrorDone
label earlyErrorDone "earlyError.done"
my br $cleanup
# If the variable doesn't exist anymore and no-one's using it,
# then free up the relevant structures and hash table entries.
label cleanup:
set values [list $nullResultPtr $resultPtr $nullResultPtr]
set origins [list $callWriteTraces $slowReturn $earlyErrorDone]
set resultPtr [my phi $values $origins "resultPtr"]
my condBr [my nonnull $resultPtr] \
$cleanupErrorCode $test11
label cleanupErrorCode "cleanup.errorCode"
$api Tcl_SetObjErrorCode $interp \
[$api obj.constant {TCL WRITE VARNAME}]
my br $test11
label test11:
my condBr [my Call var.defined $varPtr] \
$cleanupDone $cleanupVar
label cleanupVar "cleanup.var"
$api TclCleanupVar $varPtr $arrayPtr
my br $cleanupDone
label cleanupDone "cleanup.done"
my ret $resultPtr
}
##### Function var.deleteSearches #####
#
# Replica of DeleteSearches.
set f [$m local var.deleteSearches void<-Tcl_Interp*,Var*]
params interp varPtr
build {
nonnull $interp
my condBr [my nonnull $varPtr] $testBit $done
label testBit
my condBr [my Call var.hasSearch $varPtr] $deleteSearches $done
label deleteSearches "delete.searches"
set tablePtr [my gep $interp 0 Tcl_Interp.varSearches]
set sPtr [$api TclFindHashEntry $tablePtr $varPtr]
SetValueName $sPtr "sPtr"
set store [my alloc ArraySearch*]
set value [$api Tcl_GetHashValue $sPtr ArraySearch*]
SetValueName $value "searchPtr"
my store $value $store
my br $loopTest
label loopTest "loop.test"
set search [my load $store "searchPtr"]
my condBr [my nonnull $search] $loopBody $loopDone
label loopBody "loop.body"
my store [my dereference $search 0 ArraySearch.nextPtr] $store
$api Tcl_DecrRefCount [my dereference $search 0 ArraySearch.name]
$api ckfree $search
my br $loopTest
label loopDone "loop.done"
my Call var.flag.clear $varPtr $SEARCH_ACTIVE
$api Tcl_DeleteHashEntry $sPtr
my br $done
label done:
my ret
}
##### Function var.eventuallyFreeTrace #####
#
# Wrapper round Tcl_EventuallyFree to coerce types right.
set f [$m local var.eventuallyFreeTrace void<-VarTrace*]
params trace
build {
nonnull $trace
set TCL_DYNAMIC [my castInt2Ptr [Const 3] func{void<-void*}*]
$api Tcl_EventuallyFree [my cast(ptr) $trace char] $TCL_DYNAMIC
my ret
}
##### Function tcl.unset.var.array #####
#
# Replica of DeleteArray, except without index parameter.
set f [$m local tcl.unset.var.array \
void<-Tcl_Interp*,Tcl_Obj*,Var*,int]
params interp part1Ptr varPtr flags
build {
nonnull $interp $part1Ptr $varPtr
my Call var.deleteSearches $interp $varPtr
set search [my alloc Tcl_HashSearch "search"]
set elPtr [my alloc Var* "elPtr"]
my store [my Call var.hash.firstVar \
[my Call var.table $varPtr] $search] $elPtr
my br $loopTest
label loopTest "loop.test"
set element [my load $elPtr "element"]
my condBr [my nonnull $element] $loopBody $loopDone
label loopBody "loop.body"
my condBr [my and [my Call var.isScalar $element] \
[my Call var.defined $element]] \
$clearContents $considerTraces
label clearContents "clear.element.contents"
$api Tcl_DecrRefCount [my Call var.value $element]
my Call var.value.set $element [my null Tcl_Obj*]
my br $considerTraces
# Lie about the validity of the hashtable entry. In this way the
# variables will be deleted by VarHashDeleteTable.
label considerTraces "consider.element.traces"
my Call var.hash.invalidateEntry $element
my condBr [my Call var.isTraced $element] \
$handleTraces $clearElement
label handleTraces "handle.element.traces"
my condBr [my Call var.isTraced.unset $element] \
$callTraces $squelchTraces
label callTraces "call.element.traces"
set elName [my Call var.hash.getKey $element]
my Call var.flag.clear $element $TRACE_ACTIVE
# NB: We know that elName is nonnull here
$api TclCallVarTraces $interp [my null Var*] $element \
[$api Tcl_GetString $part1Ptr] \
[$api Tcl_GetString $elName] \
$flags $0
my br $squelchTraces
label squelchTraces "squelch.element.traces"
set varTraces [my gep $interp 0 Tcl_Interp.varTraces]
set tPtr [$api TclFindHashEntry $varTraces $element]
SetValueName $tPtr "tPtr"
set tracePtr [my alloc VarTrace* "tracePtr"]
set value [$api Tcl_GetHashValue $tPtr VarTrace*]
SetValueName $value "tracePtr"
my store $value $tracePtr
my br $squelchTracesTest
label squelchTracesTest "squelch.element.traces.test"
set trace [my load $tracePtr "trace"]
my condBr [my nonnull $trace] $squelchTracesBody $clearActives
label squelchTracesBody "squelch.element.traces.body"
my store [my dereference $trace 0 VarTrace.nextPtr] $tracePtr
my store [my null VarTrace*] [my gep $trace 0 VarTrace.nextPtr]
my Call var.eventuallyFreeTrace $trace
my br $squelchTracesTest
label clearActives "clear.element.traces.active"
$api Tcl_DeleteHashEntry $tPtr
my Call var.flag.clear $element $TRACED_ALL
set activePtr [my alloc ActiveVarTrace* "activePtr"]
my store [my dereference $interp 0 Tcl_Interp.activeVarTracePtr] \
$activePtr
my br $clearActivesTest
label clearActivesTest "clear.element.traces.active.test"
set active [my load $activePtr "active"]
my condBr [my nonnull $active] $clearActivesBody $clearElement
label clearActivesBody "clear.element.traces.active.body"
set tracedVar [my dereference $active 0 ActiveVarTrace.varPtr]
my condBr [my eq $tracedVar $element] \
$clearActivesClear $clearActivesNext
label clearActivesClear "clear.element.traces.active.next"
my store [my null VarTrace*] \
[my gep $active 0 ActiveVarTrace.nextTracePtr]
my br $clearActivesNext
label clearActivesNext "clear.element.traces.active.next"
my store [my dereference $active 0 ActiveVarTrace.nextPtr] \
$activePtr
my br $clearActivesTest
label clearElement "clear.element"
my Call var.value.set.undefined $element
# Even though array elements are not supposed to be namespace
# variables, some combinations of [upvar] and [variable] may
# create such beasts - see [Bug 604239]. This is necessary to
# avoid leaking the corresponding Var struct, and is otherwise
# harmless.
my Call var.clearNamespaceVar $element
my br $loopNext
label loopNext "loop.next"
my store [my Call var.hash.nextVar $search] $elPtr
my br $loopTest
label loopDone "loop.done"
my Call var.hash.delete $varPtr
my ret
}
##### Function var.dispose.activetraces #####
#
# Helper for tcl.unset.var.struct to make that code simpler.
set f [$m local var.dispose.activetraces \
void<-Tcl_Interp*,Var*,VarTrace*]
params interp varPtr tracePtr
build {
set store [my alloc VarTrace* "store"]
my store $tracePtr $store
my br $traceTest
label traceTest:
set trace [my load $store "trace"]
my condBr [my nonnull $trace] $traceBody $unlinkActive
label traceBody:
my store [my dereference $trace 0 VarTrace.nextPtr] $store
my store [my null VarTrace*] [my gep $trace 0 VarTrace.nextPtr]
my Call var.eventuallyFreeTrace $trace
my br $traceTest
label unlinkActive:
set store [my alloc ActiveVarTrace* "store"]
my store [my dereference $interp 0 Tcl_Interp.activeVarTracePtr] \
$store
my br $activeTest
label activeTest:
set active [my load $store "activeTrace"]
my condBr [my nonnull $active] $activeBody $done
label activeBody:
set activeVar [my dereference $active 0 ActiveVarTrace.varPtr]
my condBr [my eq $activeVar $varPtr] $activeBody2 $activeNext
label activeBody2:
my store [my null VarTrace*] \
[my gep $active 0 ActiveVarTrace.nextTracePtr]
my br $activeNext
label activeNext:
my store [my dereference $active 0 ActiveVarTrace.nextPtr] \
$store
my br $activeTest
label done:
my ret
}
##### Function tcl.unset.var.struct #####
#
# Replica of UnsetVarStruct, except without index parameter.
set f [$m local tcl.unset.var.struct \
void<-Var*,Var*,Tcl_Interp*,Tcl_Obj*,Tcl_Obj*,int]
params varPtr arrayPtr interp part1Ptr part2Ptr flags
build {
nonnull $varPtr $interp $part1Ptr
set dummyVar [my alloc Var "dummyVar"]
my br $ct1
label ct1 "computing.traced"
set t [my Call var.isTraced $varPtr]
my condBr $t $ct4 $ct2
label ct2 "check.array.for.traced"
my condBr [my nonnull $arrayPtr] \
$ct3 $ct4
label ct3 "check.array.for.traced"
set t2 [my Call var.isTraced.unset $arrayPtr]
my br $ct4
label ct4 "computed.traced"
set sources [list $ct1 $ct2 $ct3]
set traced [my phi [list $t $t $t2] $sources "traced"]
my Call var.deleteSearches $interp $arrayPtr
my Call var.deleteSearches $interp $varPtr
# The code below is tricky, because of the possibility that a
# trace function might try to access a variable being deleted. To
# handle this situation gracefully, do things in three steps:
# 1. Copy the contents of the variable to a dummy variable
# structure, and mark the original Var structure as undefined.
# 2. Invoke traces and clean up the variable, using the dummy
# copy.
# 3. If at the end of this the original variable is still
# undefined and has no outstanding references, then delete it
# (but it could have gotten recreated by a trace).
set dummy [my load $varPtr]
set dummy [my insert $dummy [my and [my not $ALL_HASH] \
[my extract $dummy Var.flags]] Var.flags]
my store $dummy $dummyVar
my Call var.value.set.undefined $varPtr
# Call trace functions for the variable being deleted. Then delete
# its traces. Be sure to abort any other traces for the variable
# that are still pending. Special tricks:
# 1. We need to increment varPtr's refCount around this:
# TclCallVarTraces will use dummyVar so it won't increment
# varPtr's refCount itself.
# 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
# call unset traces even if other traces are pending.
my condBr $traced $processTraces $clearValues
label processTraces "process.traces"
set varTraces [my gep $interp 0 Tcl_Interp.varTraces]
set traceActive [my alloc VarTrace*]
my store [my null VarTrace*] $traceActive
my condBr [my Call var.isTraced $dummyVar] \
$removeUnsetTraces $callUnsetTraces
# Transfer any existing traces on var, IF there are unset traces.
# Otherwise just delete them.
label removeUnsetTraces "remove.original.traces"
set tPtr [$api TclFindHashEntry $varTraces $varPtr]
SetValueName $tPtr "tPtr"
set tracePtr [$api Tcl_GetHashValue $tPtr VarTrace*]
SetValueName $tracePtr "tracePtr"
my store $tracePtr $traceActive
my Call var.flag.clear $varPtr $TRACED_ALL
$api Tcl_DeleteHashEntry $tPtr
my condBr [my Call var.isTraced.unset $dummyVar] \
$recreateUnsetTraces $callUnsetTracesCheck
label recreateUnsetTraces "recreate.unset.traces"
set tPtr [$api TclCreateHashEntry $varTraces $dummyVar]
SetValueName $tPtr "tPtr"
$api Tcl_SetHashValue $tPtr $tracePtr
my br $callUnsetTracesCheck
label callUnsetTracesCheck "call.unset.traces.check"
my condBr [my Call var.isTraced.unset $dummyVar] \
$callUnsetTraces $callUnsetTracesCheck2
label callUnsetTracesCheck2 "call.unset.traces.check"
my condBr [my nonnull $arrayPtr] \
$callUnsetTracesCheck3 $disposeActiveTraces
label callUnsetTracesCheck3 "call.unset.traces.check"
my condBr [my Call var.isTraced.unset $arrayPtr] \
$callUnsetTraces $disposeActiveTraces
label callUnsetTraces "call.unset.traces"
my Call var.flag.clear $dummyVar $TRACE_ACTIVE
$api TclCallVarTraces $interp $arrayPtr $dummyVar \
[$api Tcl_GetString $part1Ptr] \
[my Call tcl.getornull $part2Ptr] \
[my or [my and $flags $NSGLBL] $TRACED_UNSETS] $0
# The traces that we just called may have triggered a change in
# the set of traces. If so, reload the traces to manipulate.
my store [my null VarTrace*] $traceActive
my condBr [my Call var.isTraced $dummyVar] \
$refetchActive $disposeActiveTraces
label refetchActive "refetch.active.trace"
set tPtr [$api TclFindHashEntry $varTraces $dummyVar]
SetValueName $tPtr "tPtr"
my condBr [my nonnull $tPtr] \
$refetchActive2 $disposeActiveTraces
label refetchActive2 "refetch.active.trace"
set tracePtr [$api Tcl_GetHashValue $tPtr VarTrace*]
SetValueName $tracePtr "tracePtr"
my store $tracePtr $traceActive
$api Tcl_DeleteHashEntry $tPtr
my br $disposeActiveTraces
label disposeActiveTraces "dispose.active.traces"
set tracePtr [my load $traceActive "tracePtr"]
my condBr [my nonnull $tracePtr] $disposeClear $clearValues
label disposeClear "dispose.active.traces.clear"
my Call var.dispose.activetraces $interp $varPtr $tracePtr
my Call var.flag.clear $dummyVar $TRACED_ALL
my br $clearValues
label clearValues "clear.values"
my condBr [my and \
[my Call var.isScalar $dummyVar] \
[my Call var.defined $dummyVar]] \
$clearScalar $clearArrayTest
label clearScalar "clear.scalar"
$api Tcl_DecrRefCount [my Call var.value $dummyVar]
my br $clearNsVar
label clearArrayTest "clear.array.test"
my condBr [my Call var.isArray $dummyVar] \
$clearArray $clearLinkTest
label clearArray "clear.array"
# If the variable is an array, delete all of its elements. This
# must be done after calling and deleting the traces on the array,
# above (that's the way traces are defined). If the array name is
# not present and is required for a trace on some element, it will
# be computed at DeleteArray.
my Call tcl.unset.var.array $interp $part1Ptr $dummyVar \
[my or [my and $flags $NSGLBL] $TRACED_UNSETS]
my br $clearNsVar
label clearLinkTest "clear.link.test"
my condBr [my Call var.isLink $dummyVar] \
$clearLink $clearNsVar
label clearLink "clear.link"
# For global/upvar variables referenced in procedures, decrement
# the reference count on the variable referred to, and free the
# referenced variable if it's no longer needed.
set linked [my Call var.link $dummyVar]
SetValueName $linked "linkedVarPtr"
my condBr [my Call var.isInHash $linked] \
$cleanLinked $clearNsVar
label cleanLinked "clean.linked.variable"
set rcref [my Call var.hash.refCount $linked]
my store [my sub [my load $rcref] $1] $rcref
$api TclCleanupVar $linked [my null Var*]
my br $clearNsVar
# If the variable was a namespace variable, decrement its
# reference count.
label clearNsVar "clear.namespace.var"
my Call var.clearNamespaceVar $varPtr
my ret
}
##### Function tcl.unset.var.ptr #####
#
# Replica of TclPtrUnsetVar, except without index parameter.
set f [$m local tcl.unset.var.ptr \
int<-Tcl_Interp*,Var*,Var*,Tcl_Obj*,Tcl_Obj*,int]
params interp varPtr arrayPtr part1Ptr part2Ptr flags
build {
set result [my select [my Call var.defined $varPtr] $0 $1 "result"]
# Keep the variable alive until we're done with it. We used to
# increase/decrease the refCount for each operation, making it
# hard to find [Bug 735335] - caused by unsetting the variable
# whose value was the variable's name.
my condBr [my Call var.isInHash $varPtr] \
$addRef $uvs
label addRef "add.reference"
set rcref [my Call var.hash.refCount $varPtr]
my store [my add [my load $rcref] $1] $rcref
my br $uvs
label uvs "unset.var.struct"
my Call tcl.unset.var.struct $varPtr $arrayPtr $interp \
$part1Ptr $part2Ptr $flags
# It's an error to unset an undefined variable.
my condBr [my eq $result $0] \
$finalCleanup $handleError
label handleError "handle.error"
my condBr [my eq [my and $flags $LEAVE_ERR_MSG] $0] \
$finalCleanup $generateError
label generateError "generate.error"
set noSuchElement [my constString "no such element in array" "noSuchElement"]
set noSuchVar [my constString "no such variable" "noSuchVar"]
set msg [my select [my nonnull $arrayPtr] \
$noSuchElement $noSuchVar]
$api TclVarErrMsg $interp [$api Tcl_GetString $part1Ptr] \
[my Call tcl.getornull $part2Ptr] \
[my constString "unset"] $msg
$api Tcl_SetObjErrorCode $interp \
[$api obj.constant {TCL UNSET VARNAME}]
my br $finalCleanup
# Finally, if the variable is truly not in use then free up its
# Var structure and remove it from its hash table, if any. The ref
# count of its value object, if any, was decremented above.
label finalCleanup "final.cleanup"
my condBr [my Call var.isInHash $varPtr] \
$doCleanup $done
label doCleanup "cleanup"
set rcref [my Call var.hash.refCount $varPtr]
my store [my sub [my load $rcref] $1] $rcref
$api TclCleanupVar $varPtr $arrayPtr
my br $done
label done:
my ret $result
}
##### Function tcl.read.global.ns #####
#
# Type signature: ns:NAMESPACE * varname:STRING * ecvar:int*
# -> STRING?
#
# Reads from a global (or other namespace) variable.
set f [$m local tcl.read.global.ns STRING?<-Namespace*,STRING,int*]
params ns varname ecvar
build {
nonnull $ns $varname $ecvar
set interp [$api tclInterp]
set arrayPtr [my alloc Var*]
# save NS
set frameNsPtr [my gep \
[my dereference $interp 0 Tcl_Interp.varFramePtr] \
0 CallFrame.nsPtr]
set savedNs [my load $frameNsPtr "savedNs"]
my store $ns $frameNsPtr
set var [$api TclObjLookupVar $interp $varname \
[my null char*] [Const [expr {2+0x200+0x40000}]] \
[my constString "access"] $1 $1 $arrayPtr]
# restore NS
my store $savedNs $frameNsPtr
my condBr [my expect [my nonnull $var] true] \
$gotVar $fail
label gotVar:
set result [my Call tcl.read.var.ptr $interp \
$var [my null Var*] $varname [my null Tcl_Obj*] \
$LEAVE_ERR_MSG]
my condBr [my expect [my nonnull $result] true] \
$gotValue $fail
label gotValue:
my addReference(STRING) $result
my ret [my just $result]
label fail:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.read.global #####
#
# Type signature: ns:STRING * varname:STRING * ecvar:int* -> STRING?
#
# Reads from a global (or other namespace) variable.
set f [$m local tcl.read.global STRING?<-STRING,STRING,int*]
params nsname varname ecvar
build {
nonnull $nsname $varname $ecvar
set interp [$api tclInterp]
set nsptr [my alloc Namespace*]
set code [$api TclGetNamespaceFromObj $interp $nsname $nsptr]
my condBr [my expect [my eq $code $0] true] $gotNS $fail
label gotNS:
set ns [my load $nsptr]
my ret [my Call tcl.read.global.ns $ns $varname $ecvar]
label fail:
my store $1 $ecvar
my ret [my nothing STRING]
}
##### Function tcl.namespace.global #####
#
# Type signature: void -> NAMESPACE
#
# Gets the handle to the global namespace.
set f [$m local tcl.namespace.global Namespace*<-]
params
build {
set interp [$api tclInterp]
my ret [my dereference $interp 0 Tcl_Interp.globalNsPtr]
}
##### Function tcl.namespace.current #####
#
# Type signature: void -> NAMESPACE
#
# Gets the handle to the current namespace.
set f [$m local tcl.namespace.current Namespace*<-]
params
build {
set interp [$api tclInterp]
set frame [my dereference $interp 0 Tcl_Interp.varFramePtr]
my ret [my dereference $frame 0 CallFrame.nsPtr]
}
}
export @apiFunctions
}
# Local Variables:
# mode: tcl
# fill-column: 78
# auto-fill-function: nil
# buffer-file-coding-system: utf-8-unix
# End: