Index: codegen/build.tcl ================================================================== --- codegen/build.tcl +++ codegen/build.tcl @@ -2125,32 +2125,34 @@ method concat() {vector {name ""}} { my ExtractVector $vector my call ${tcl.concatenate} [list $len $ary] $name } - # Builder:dictAppend(STRING,STRING,STRING) -- + # Builder:dictAppend(DICT,STRING,STRING) -- # - # Append a value to a key in a dictionary. NOTE: this operation can fail - # (e.g., because it can be given an invalid dictionary) so it produces a - # STRING FAIL. Quadcode implementation ('dictAppend'). + # Append a value to a key in a dictionary. Quadcode implementation + # ('dictAppend'). # # Parameters: # dict - The dictionary as an LLVM value reference. # key - The key as an LLVM value reference. # value - The value to append as an LLVM value reference. - # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: - # The resulting dictionary as an LLVM value reference, or a FAIL. + # The resulting dictionary as an LLVM value reference. - method dictAppend(STRING,STRING,STRING) {dict key value ec {name ""}} { - my call ${tcl.dict.append} [list $dict $key $value $ec] $name + method dictAppend(DICT,STRING,STRING) {dict key value {name ""}} { + my call ${tcl.dict.append} [list $dict $key $value] $name + } + method dictAppend(EMPTY,STRING,STRING) {dict key value {name ""}} { + # TODO: Optimize case? + my call ${tcl.dict.append} [list $dict $key $value] $name } - # Builder:dictExists(STRING) -- + # Builder:dictExists(DICT) -- # # Find whether a key exists in a dictionary. This version uses a vector # of values for the key path. Quadcode implementation ('dictExists'). # # Parameters: @@ -2161,16 +2163,19 @@ # A name to give to the result value. # # Results: # Whether the value exists as an LLVM ZEROONE value reference. - method dictExists(STRING) {dict vector {name ""}} { + method dictExists(DICT) {dict vector {name ""}} { my ExtractVector $vector my call ${tcl.dict.exists} [list $dict $len $ary] $name } + method dictExists(EMPTY) {dict vector {name ""}} { + Const 0 int1 + } - # Builder:dictExists(STRING,STRING) -- + # Builder:dictExists(DICT,STRING) -- # # Find whether a key exists in a dictionary. This version uses a single # simple key. Quadcode implementation ('dictExists'). # # Parameters: @@ -2180,20 +2185,23 @@ # A name to give to the result value. # # Results: # Whether the value exists as an LLVM ZEROONE value reference. - method dictExists(STRING,STRING) {dict key {name ""}} { + method dictExists(DICT,STRING) {dict key {name ""}} { my call ${tcl.dict.exists1} [list $dict $key] $name } + method dictExists(EMPTY,STRING) {dict key {name ""}} { + Const 0 int1 + } - # Builder:dictGet(STRING) -- + # Builder:dictGet(DICT) -- # # Retrieve a value from a dictionary. This version uses a vector as a - # key path. NOTE: this operation can fail (e.g., because it can be given - # an invalid dictionary) so it produces a STRING FAIL. Quadcode - # implementation ('dictGet'). + # key path. NOTE: this operation can fail (e.g., a key not present or an + # invalid dictionary inside a valid one) so it produces a STRING FAIL. + # Quadcode implementation ('dictGet'). # # Parameters: # dict - The dictionary as an LLVM value reference. # vector - # The key path as an LLVM vector value reference. @@ -2202,21 +2210,25 @@ # A name to give to the result value. # # Results: # The retrieved value as an LLVM value reference, or a FAIL. - method dictGet(STRING) {dict vector ec {name ""}} { + method dictGet(DICT) {dict vector ec {name ""}} { + my ExtractVector $vector + my call ${tcl.dict.get} [list $dict $len $ary $ec] $name + } + method dictGet(EMPTY) {dict vector ec {name ""}} { + # TODO: Optimize case? my ExtractVector $vector my call ${tcl.dict.get} [list $dict $len $ary $ec] $name } - # Builder:dictGet(STRING,STRING) -- + # Builder:dictGet(DICT,STRING) -- # # Retrieve a value from a dictionary. This version uses a single simple - # key. NOTE: this operation can fail (e.g., because it can be given an - # invalid dictionary) so it produces a STRING FAIL. Quadcode - # implementation ('dictGet'). + # key. NOTE: this operation can fail so it produces a STRING FAIL. + # Quadcode implementation ('dictGet'). # # Parameters: # dict - The dictionary as an LLVM value reference. # key - The key as an LLVM value reference. # ec - Where to write the error code if an error happens. @@ -2224,37 +2236,43 @@ # A name to give to the result value. # # Results: # The retrieved value as an LLVM value reference, or a FAIL. - method dictGet(STRING,STRING) {dict key ec {name ""}} { + method dictGet(DICT,STRING) {dict key ec {name ""}} { + my call ${tcl.dict.get1} [list $dict $key $ec] $name + } + method dictGet(EMPTY,STRING) {dict key ec {name ""}} { + # TODO: Optimize case? my call ${tcl.dict.get1} [list $dict $key $ec] $name } - # Builder:dictGetOrNexist(STRING,STRING) -- + # Builder:dictGetOrNexist(EMPTY DICT,STRING) -- # # Retrieve a value from a dictionary, or NEXIST if the key doesn't map - # to a value in the dict. This version uses a single simple key. NOTE: - # this operation can fail (e.g., because it can be given an invalid - # dictionary) so it produces a FAIL NEXIST STRING. Quadcode - # implementation ('dictGetOrNexist'). + # to a value in the dict. This version uses a single simple key. + # Quadcode implementation ('dictGetOrNexist'). # # Parameters: # dict - The dictionary as an LLVM value reference. # key - The key as an LLVM value reference. # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: - # The retrieved value as an LLVM value reference, or a NEXIST or FAIL. + # The retrieved value as an LLVM value reference, or a NEXIST. - method dictGetOrNexist(STRING,STRING) {dict key ec {name ""}} { - my call ${tcl.dict.get1.empty} [list $dict $key $ec] $name + method dictGetOrNexist(DICT,STRING) {dict key {name ""}} { + my call ${tcl.dict.get1.empty} [list $dict $key] $name + } + method dictGetOrNexist(EMPTY,STRING) {dict key {name ""}} { + # TODO: Optimize case + my call ${tcl.dict.get1.empty} [list $dict $key] $name } - # Builder:dictIncr(STRING,STRING,INT) -- + # Builder:dictIncr(EMPTY DICT,STRING,INT) -- # # Increment the value for a key in a dictionary. NOTE: this operation # can fail (e.g., because it can be given an invalid dictionary) so it # produces a STRING FAIL. Quadcode implementation ('dictIncr'). # @@ -2267,32 +2285,38 @@ # A name to give to the result value. # # Results: # The resulting dictionary as an LLVM value reference, or a FAIL. - method dictIncr(STRING,STRING,INT) {dict key value ec {name ""}} { + method dictIncr(DICT,STRING,INT) {dict key value ec {name ""}} { + my call ${tcl.dict.incr} [list $dict $key $value $ec] $name + } + method dictIncr(EMPY,STRING,INT) {dict key value ec {name ""}} { + # TODO: Optimize case my call ${tcl.dict.incr} [list $dict $key $value $ec] $name } - # Builder:dictIterStart(STRING) -- + # Builder:dictIterStart(DICT) -- # # Start iterating over a dictionary; other opcodes are used to retrieve - # what the state of the iteration is. NOTE: this operation can fail - # (e.g., because it can be given an invalid dictionary) so it produces a - # DICTITER FAIL. Quadcode implementation ('dictIterStart'). + # what the state of the iteration is. Quadcode implementation + # ('dictIterStart'). # # Parameters: # dict - The dictionary as an LLVM value reference. - # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: - # The iteration state as an LLVM DICTITER value reference, or a FAIL. + # The iteration state as an LLVM DICTITER value reference. - method dictIterStart(STRING) {dict ec {name ""}} { - my call ${tcl.dict.iterStart} [list $dict $ec] $name + method dictIterStart(DICT) {dict {name ""}} { + my call ${tcl.dict.iterStart} [list $dict] $name + } + method dictIterStart(EMPTY) {dict {name ""}} { + # TODO: Optimize case + my call ${tcl.dict.iterStart} [list $dict] $name } # Builder:dictIterNext -- # # Get the next step when iterating over a dictionary; other opcodes are @@ -2360,15 +2384,15 @@ method dictIterDone {iter {name ""}} { my call ${tcl.dict.iterDone} [list $iter] $name } - # Builder:dictLappend(STRING,STRING,STRING) -- + # Builder:dictLappend(DICT,STRING,STRING) -- # # List-append a value to a key in a dictionary. NOTE: this operation can # fail (e.g., because it can be given an invalid dictionary) so it - # produces a STRING FAIL. Quadcode implementation ('dictLappend'). + # produces a DICT FAIL. Quadcode implementation ('dictLappend'). # # Parameters: # dict - The dictionary as an LLVM value reference. # key - The key as an LLVM value reference. # value - The value to append as an LLVM value reference. @@ -2377,20 +2401,24 @@ # A name to give to the result value. # # Results: # The resulting dictionary as an LLVM value reference, or a FAIL. - method dictLappend(STRING,STRING,STRING) {dict key value ec {name ""}} { + method dictLappend(DICT,STRING,STRING) {dict key value ec {name ""}} { + my call ${tcl.dict.lappend} [list $dict $key $value $ec] $name + } + method dictLappend(EMPTY,STRING,STRING) {dict key value ec {name ""}} { + # TODO: Optimize case my call ${tcl.dict.lappend} [list $dict $key $value $ec] $name } - # Builder:dictSet(STRING,STRING) -- + # Builder:dictSet(DICT,STRING) -- # # Set or create a value in a dictionary. This version uses a vector as a - # dictionary key path. NOTE: this operation can fail (e.g., because it - # can be given an invalid dictionary) so it produces a STRING FAIL. - # Quadcode implementation ('dictSet'). + # dictionary key path.. NOTE: this operation can fail (e.g., because + # there is an invalid dictionary nested inside) so it produces a DICT + # FAIL. Quadcode implementation ('dictSet'). # # Parameters: # dict - The dictionary as an LLVM value reference. # value - The value as an LLVM value reference. # vector - @@ -2398,129 +2426,139 @@ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: - # The new dictionary value. + # The new dictionary value or a FAIL. - method dictSet(STRING,STRING) {dict value vector ec {name ""}} { + method dictSet(DICT,STRING) {dict value vector ec {name ""}} { + my ExtractVector $vector + my call ${tcl.dict.set} [list $dict $len $ary $value $ec] $name + } + method dictSet(EMPTY,STRING) {dict value vector ec {name ""}} { + # TODO: Optimize case my ExtractVector $vector my call ${tcl.dict.set} [list $dict $len $ary $value $ec] $name } - # Builder:dictSet(STRING,STRING,STRING) -- + # Builder:dictSet(DICT,STRING,STRING) -- # # Set or create a value in a dictionary. This version uses a single - # simple key. NOTE: this operation can fail (e.g., because it can be - # given an invalid dictionary) so it produces a STRING FAIL. Quadcode - # implementation ('dictSet'). + # simple key. Quadcode implementation ('dictSet'). # # Parameters: # dict - The dictionary as an LLVM value reference. # key - The key as an LLVM value reference. # value - The value as an LLVM value reference. - # ec - Where to write the error code if an error happens. + # name (optional) - + # A name to give to the result value. + # + # Results: + # The new dictionary value. + + method dictSet(DICT,STRING,STRING) {dict key value {name ""}} { + my call ${tcl.dict.set1} [list $dict $key $value] $name + } + method dictSet(EMPTY,STRING,STRING) {dict key value {name ""}} { + # TODO: Optimize case + my call ${tcl.dict.set1} [list $dict $key $value] $name + } + + # Builder:dictSetOrUnset(DICT,STRING,NEXIST) -- + # + # Remove a value in a dictionary. This version uses a single simple key. + # Quadcode implementation ('dictSetOrUnset'). + # + # Parameters: + # dict - The dictionary as an LLVM value reference. + # key - The key as an LLVM value reference. + # value - The NEXIST value (actually ignored). + # name (optional) - + # A name to give to the result value. + # + # Results: + # The new dictionary value. + + method dictSetOrUnset(DICT,STRING,NEXIST) {dict key value {name ""}} { + my call ${tcl.dict.set1.empty} [list $dict $key [my nothing STRING]] $name + } + method dictSetOrUnset(EMPTY,STRING,NEXIST) {dict key value {name ""}} { + # TODO: Optimize case + my call ${tcl.dict.set1.empty} [list $dict $key [my nothing STRING]] $name + } + + # Builder:dictSetOrUnset(DICT,STRING,NEXIST STRING) -- + # + # Set, create or remove a value in a dictionary. This version uses a + # single simple key, and the value can be NEXIST to remove the key. + # Quadcode implementation ('dictSetOrUnset'). + # + # Parameters: + # dict - The dictionary as an LLVM value reference. + # key - The key as an LLVM value reference. + # value - The value as an LLVM value reference, or NEXIST. + # name (optional) - + # A name to give to the result value. + # + # Results: + # The new dictionary value. + + method dictSetOrUnset(DICT,STRING,NEXIST\040STRING) {dict key value {name ""}} { + my call ${tcl.dict.set1.empty} [list $dict $key $value] $name + } + method dictSetOrUnset(EMPTY,STRING,NEXIST\040STRING) {dict key value {name ""}} { + # TODO: Optimize case + my call ${tcl.dict.set1.empty} [list $dict $key $value] $name + } + + # Builder:dictSetOrUnset(DICT,STRING,NEXIST STRING) -- + # + # Set or create a value in a dictionary. This version uses a single + # simple key. Quadcode implementation ('dictSetOrUnset'). + # + # Parameters: + # dict - The dictionary as an LLVM value reference. + # key - The key as an LLVM value reference. + # value - The value as an LLVM value reference. # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. - method dictSet(STRING,STRING,STRING) {dict key value ec {name ""}} { - my call ${tcl.dict.set1} [list $dict $key $value $ec] $name - } - - # Builder:dictSetOrUnset(STRING,STRING,NEXIST) -- - # - # Remove a value in a dictionary. This version uses a single simple key. - # NOTE: this operation can fail (e.g., because it can be given an - # invalid dictionary) so it produces a STRING FAIL. Quadcode - # implementation ('dictSetOrUnset'). - # - # Parameters: - # dict - The dictionary as an LLVM value reference. - # key - The key as an LLVM value reference. - # value - The NEXIST value (actually ignored). - # ec - Where to write the error code if an error happens. - # name (optional) - - # A name to give to the result value. - # - # Results: - # The new dictionary value, or FAIL. - - method dictSetOrUnset(STRING,STRING,NEXIST) {dict key value ec {name ""}} { - my call ${tcl.dict.set1.empty} [list $dict $key [my nothing STRING] $ec] $name - } - - # Builder:dictSetOrUnset(STRING,STRING,NEXIST STRING) -- - # - # Set, create or remove a value in a dictionary. This version uses a - # single simple key, and the value can be NEXIST to remove the key. - # NOTE: this operation can fail (e.g., because it can be given an - # invalid dictionary) so it produces a STRING FAIL. Quadcode - # implementation ('dictSetOrUnset'). - # - # Parameters: - # dict - The dictionary as an LLVM value reference. - # key - The key as an LLVM value reference. - # value - The value as an LLVM value reference, or NEXIST. - # ec - Where to write the error code if an error happens. - # name (optional) - - # A name to give to the result value. - # - # Results: - # The new dictionary value, or FAIL. - - method dictSetOrUnset(STRING,STRING,NEXIST\040STRING) {dict key value ec {name ""}} { - my call ${tcl.dict.set1.empty} [list $dict $key $value $ec] $name - } - - # Builder:dictSetOrUnset(STRING,STRING,NEXIST STRING) -- - # - # Set or create a value in a dictionary. This version uses a single - # simple key. NOTE: this operation can fail (e.g., because it can be - # given an invalid dictionary) so it produces a STRING FAIL. Quadcode - # implementation ('dictSetOrUnset'). - # - # Parameters: - # dict - The dictionary as an LLVM value reference. - # key - The key as an LLVM value reference. - # value - The value as an LLVM value reference. - # ec - Where to write the error code if an error happens. - # name (optional) - - # A name to give to the result value. - # - # Results: - # The new dictionary value, or FAIL. - - method dictSetOrUnset(STRING,STRING,STRING) {dict key value ec {name ""}} { - my call ${tcl.dict.set1.empty} [list $dict $key [my just $value] $ec] $name - } - - # Builder:dictSize(STRING) -- + method dictSetOrUnset(DICT,STRING,STRING) {dict key value {name ""}} { + my call ${tcl.dict.set1.empty} [list $dict $key [my just $value]] $name + } + method dictSetOrUnset(EMPTY,STRING,STRING) {dict key value {name ""}} { + # TODO: Optimize case + my call ${tcl.dict.set1.empty} [list $dict $key [my just $value]] $name + } + + # Builder:dictSize(DICT) -- # # Get the size of a dictionary, i.e., the number of key-value pairs. # # Parameters: # value - The STRING LLVM value reference to a dict to get the size of. - # ecvar - Location to write the Tcl return code into, as an LLVM int* - # reference. # name (optional) - # A name to give to the result value. # # Results: - # An INT FAIL in an LLVM value reference. + # An INT in an LLVM value reference. - method dictSize(STRING) {value ecvar {name ""}} { - my call ${tcl.dict.size} [list $value $ecvar] $name + method dictSize(DICT) {value {name ""}} { + my call ${tcl.dict.size} [list $value] $name + } + method dictSize(EMPTY) {value ecvar {name ""}} { + my packInt32 [Const 0] $name } - # Builder:dictUnset(STRING) -- + # Builder:dictUnset(DICT) -- # # Remove a key from a dictionary. This version uses a vector as a - # dictionary key path. NOTE: this operation can fail (e.g., because it - # can be given an invalid dictionary) so it produces a STRING FAIL. + # dictionary key path. NOTE: this operation can fail (e.g., because of + # an invalid dictionary inside a valid one) so it produces a DICT FAIL. # Quadcode implementation ('dictUnset'). # # Parameters: # dict - The dictionary as an LLVM value reference. # vector - @@ -2530,34 +2568,40 @@ # A name to give to the result value. # # Results: # The new dictionary value. - method dictUnset(STRING) {dict vector ec {name ""}} { + method dictUnset(DICT) {dict vector ec {name ""}} { + my ExtractVector $vector + my call ${tcl.dict.unset} [list $dict $len $ary $ec] $name + } + method dictUnset(EMPTY) {dict vector ec {name ""}} { + # TODO: Optimize case my ExtractVector $vector my call ${tcl.dict.unset} [list $dict $len $ary $ec] $name } - # Builder:dictUnset(STRING,STRING) -- + # Builder:dictUnset(DICT,STRING) -- # - # Remove a key from a dictionary. This version uses a single simple - # key. NOTE: this operation can fail (e.g., because it can be given an - # invalid dictionary) so it produces a STRING FAIL. Quadcode - # implementation ('dictUnset'). + # Remove a key from a dictionary. Quadcode implementation ('dictUnset'). # # Parameters: # dict - The dictionary as an LLVM value reference. # key - The key as an LLVM value reference. - # ec - Where to write the error code if an error happens. + # ec - Where to write the error code if an error happens. (Ignored) # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. - method dictUnset(STRING,STRING) {dict key ec {name ""}} { - my call ${tcl.dict.unset1} [list $dict $key $ec] $name + method dictUnset(DICT,STRING) {dict key ec {name ""}} { + my call ${tcl.dict.unset1} [list $dict $key] $name + } + method dictUnset(EMPTY,STRING) {dict key ec {name ""}} { + # TODO: Optimize case + my call ${tcl.dict.unset1} [list $dict $key] $name } # Builder:directAppend(STRING,STRING) -- # # Append a value to a variable, which should be referred to by a @@ -3045,10 +3089,42 @@ method dropReference {value} { my Call tcl.dropReference $value return } + + # Builder:dropReference(DICT) -- + # + # Generate code to decrement the reference count of a value and delete + # the value if it has ceased to be used. + # + # Parameters: + # value - The DICT LLVM value reference for the operand. + # + # Results: + # None. + + method dropReference(DICT) {value} { + my Call tcl.dropReference $value + return + } + + # Builder:dropReference(LIST) -- + # + # Generate code to decrement the reference count of a value and delete + # the value if it has ceased to be used. + # + # Parameters: + # value - The LIST LLVM value reference for the operand. + # + # Results: + # None. + + method dropReference(LIST) {value} { + my Call tcl.dropReference $value + return + } # Builder:dropReference(STRING) -- # # Generate code to decrement the reference count of a value and delete # the value if it has ceased to be used. @@ -4413,10 +4489,34 @@ my call ${tcl.isZeroOneBoolean} [list $value [Const false bool]] $name } method instanceOf.IMPURE_ZEROONE_BOOLEAN(STRING) {value {name ""}} { my call ${tcl.isZeroOneBoolean} [list $value [Const false bool]] $name } + + # Builder:instanceOf.DICT -- + # + # Generate code to check if the given STRING contains something that can + # be parsed to get a DICT. + + method instanceOf.DICT(STRING) {value {name ""}} { + my call ${tcl.isDict} [list $value] $name + } + method instanceOf.IMPURE_DICT(STRING) {value {name ""}} { + my call ${tcl.isDict} [list $value] $name + } + + # Builder:instanceOf.LIST -- + # + # Generate code to check if the given STRING contains something that + # can be parsed to get a LIST. + + method instanceOf.LIST(STRING) {value {name ""}} { + my call ${tcl.isList} [list $value] $name + } + method instanceOf.IMPURE_LIST(STRING) {value {name ""}} { + my call ${tcl.isList} [list $value] $name + } # Builder:int -- # # Generate code to create an integer "literal". # @@ -4839,275 +4939,291 @@ set len [Const 0] } my call ${tcl.list.create} [list $len [my gep $objv 0 0]] $name } - # Builder:listAppend(STRING,STRING) -- + # Builder:listAppend(LIST,STRING) -- # - # Append an element to a list. NOTE: this operation can fail (e.g., - # because it can be given an invalid list) so it produces a STRING FAIL. - # Quadcode implementation ('listAppend'). + # Append an element to a list. Quadcode implementation ('listAppend'). # # Parameters: # list - List value to get append to, in an LLVM STRING reference. # value - The value to append as an LLVM STRING value reference. + # name (optional) - + # A name to give to the result value. + # + # Results: + # The element of the list, as an LLVM LIST reference. + + method listAppend(LIST,STRING) {list value {name ""}} { + my call ${tcl.list.append} [list $list $value] $name + } + method listAppend(EMPTY,STRING) {list value {name ""}} { + my call ${tcl.list.append} [list $list $value] $name + } + + # Builder:listConcat(LIST,LIST) -- + # + # Append a list of elements to a list. Quadcode implementation + # ('listConcat'). + # + # Parameters: + # list - List value to get append to, in an LLVM LIST reference. + # value - The list of values to append, as an LLVM LIST reference. + # name (optional) - + # A name to give to the result value. + # + # Results: + # The concatenated list, as an LLVM LIST reference. + + method listConcat(LIST,LIST) {list value {name ""}} { + my call ${tcl.list.concat} [list $list $value] $name + } + method listConcat(LIST,EMPTY) {list value {name ""}} { + my call ${tcl.list.concat} [list $list $value] $name + } + method listConcat(EMPTY,LIST) {list value {name ""}} { + my call ${tcl.list.concat} [list $list $value] $name + } + method listConcat(EMPTY,EMPTY) {list value {name ""}} { + my call ${tcl.list.concat} [list $list $value] $name + } + + # Builder:listIn(STRING,LIST) -- + # + # Determine if an element is present in a list by simple linear search. + # Quadcode implementation ('listIn'). + # + # Parameters: + # value - The value to check for, as an LLVM STRING value reference. + # list - List value to search, in an LLVM LIST value reference. + # name (optional) - + # A name to give to the result value. + # + # Results: + # If the element is present, as an LLVM ZEROOONE reference. + + method listIn(STRING,LIST) {value list {name ""}} { + my call ${tcl.list.in} [list $value $list] $name + } + method listIn(STRING,EMPTY) {value list {name ""}} { + my call ${tcl.list.in} [list $value $list] $name + } + + # Builder:listIndex(LIST) -- + # + # Get an element of a list. NOTE: this operation can fail (e.g., because + # it can be given an invalid interior list) so it produces a STRING + # FAIL. Quadcode implementation ('listIndex'). + # + # Parameters: + # value - List value to get the length of, in an LLVM LIST reference. + # vector - + # The indices as an LLVM vector value reference. # ec - Location to write the Tcl return code into, as an LLVM int* # reference. # name (optional) - # A name to give to the result value. # # Results: # The element of the list, as an LLVM STRING FAIL reference. - method listAppend(STRING,STRING) {list value ec {name ""}} { - my call ${tcl.list.append} [list $list $value $ec] $name + method listIndex(LIST) {value vector ec {name ""}} { + my ExtractVector $vector + my call ${tcl.list.index} [list $value $len $ary $ec] $name + } + method listIndex(EMPTY) {value vector ec {name ""}} { + my ExtractVector $vector + my call ${tcl.list.index} [list $value $len $ary $ec] $name } - # Builder:listConcat(STRING,STRING) -- + # Builder:listIndex(LIST,INT) -- # - # Append a list of elements to a list. NOTE: this operation can fail - # (e.g., because it can be given an invalid list) so it produces a - # STRING FAIL. Quadcode implementation ('listConcat'). + # Get an element of a list. Quadcode implementation ('listIndex'). # # Parameters: - # list - List value to get append to, in an LLVM STRING reference. - # value - The list of values to append, as an LLVM STRING value - # reference. + # value - List value to get the length of, in an LLVM LIST reference. + # index - Index value to use, in an LLVM INT reference. + # name (optional) - + # A name to give to the result value. + # + # Results: + # The element of the list, as an LLVM STRING reference. + + method listIndex(LIST,INT) {value index {name ""}} { + my call ${tcl.list.index1} [list $value $index] $name + } + method listIndex(LIST,INT) {value index {name ""}} { + my call ${tcl.list.index1} [list $value $index] $name + } + + # Builder:listIndex(LIST,STRING) -- + # + # Get an element of a list. NOTE: this operation can fail (e.g., because + # it can be given an invalid index) so it produces a STRING FAIL. + # Quadcode implementation ('listIndex'). + # + # Parameters: + # value - List value to index into, in an LLVM LIST reference. + # index - Index value to use, in an LLVM STRING reference. # ec - Location to write the Tcl return code into, as an LLVM int* # reference. # name (optional) - # A name to give to the result value. # # Results: # The element of the list, as an LLVM STRING FAIL reference. - method listConcat(STRING,STRING) {list value ec {name ""}} { - my call ${tcl.list.concat} [list $list $value $ec] $name - } - - # Builder:listIn(STRING,STRING) -- - # - # Determine if an element is present in a list by simple linear search. - # NOTE: this operation can fail (e.g., because it can be given an - # invalid list) so it produces an INT FAIL. Quadcode implementation - # ('listIn'). - # - # Parameters: - # value - The value to check for, as an LLVM STRING value reference. - # list - List value to search, in an LLVM STRING reference. - # ec - Location to write the Tcl return code into, as an LLVM int* - # reference. - # name (optional) - - # A name to give to the result value. - # - # Results: - # If the element is present, as an LLVM INT FAIL reference. - - method listIn(STRING,STRING) {value list ec {name ""}} { - my call ${tcl.list.in} [list $value $list $ec] $name - } - - # Builder:listIndex(STRING) -- - # - # Get an element of a list. NOTE: this operation can fail (e.g., because - # it can be given an invalid list) so it produces a STRING FAIL. - # Quadcode implementation ('listIndex'). - # - # Parameters: - # value - List value to get the length of, in an LLVM STRING reference. - # vector - - # The indices as an LLVM vector value reference. - # errVar - - # Location to write the Tcl return code into, as an LLVM int* - # reference. - # name (optional) - - # A name to give to the result value. - # - # Results: - # The element of the list, as an LLVM STRING FAIL reference. - - method listIndex(STRING) {value vector ec {name ""}} { - my ExtractVector $vector - my call ${tcl.list.index} [list $value $len $ary $ec] $name - } - - # Builder:listIndex(STRING,INT) -- - # - # Get an element of a list. NOTE: this operation can fail (e.g., because - # it can be given an invalid list) so it produces a STRING FAIL. - # Quadcode implementation ('listIndex'). - # - # Parameters: - # value - List value to get the length of, in an LLVM STRING reference. - # index - Index value to use, in an LLVM INT reference. - # errVar - - # Location to write the Tcl return code into, as an LLVM int* - # reference. - # name (optional) - - # A name to give to the result value. - # - # Results: - # The element of the list, as an LLVM STRING FAIL reference. - - method listIndex(STRING,INT) {value index ec {name ""}} { - my call ${tcl.list.index1} [list $value $index $ec] $name - } - - # Builder:listIndex(STRING,STRING) -- - # - # Get an element of a list. NOTE: this operation can fail (e.g., because - # it can be given an invalid list) so it produces a STRING FAIL. - # Quadcode implementation ('listIndex'). - # - # Parameters: - # value - List value to get the length of, in an LLVM STRING reference. - # index - Index value to use, in an LLVM STRING reference. - # errVar - - # Location to write the Tcl return code into, as an LLVM int* - # reference. - # name (optional) - - # A name to give to the result value. - # - # Results: - # The element of the list, as an LLVM STRING FAIL reference. - - method listIndex(STRING,STRING) {value index ec {name ""}} { + method listIndex(LIST,STRING) {value index ec {name ""}} { + my call ${tcl.list.indexList} [list $value $index $ec] $name + } + method listIndex(EMPTY,STRING) {value index ec {name ""}} { my call ${tcl.list.indexList} [list $value $index $ec] $name } - # Builder:listLength(STRING) -- + # Builder:listLength(LIST) -- # - # Get the length of a list. NOTE: this operation can fail (e.g., because - # it can be given an invalid list) so it produces an INT FAIL. Quadcode - # implementation ('listLength'). + # Get the length of a list. Quadcode implementation ('listLength'). # # Parameters: - # value - List value to get the length of, in an LLVM STRING reference. - # errVar - - # Location to write the Tcl return code into, as an LLVM int* - # reference. + # value - List value to get the length of, in an LLVM LIST reference. # name (optional) - # A name to give to the result value. # # Results: - # The length of the list, as an LLVM INT FAIL reference. + # The length of the list, as an LLVM INT reference. - method listLength(STRING) {value ec {name ""}} { - my call ${tcl.list.length} [list $value $ec] $name + method listLength(LIST) {value {name ""}} { + my call ${tcl.list.length} [list $value] $name + } + method listLength(EMPTY) {value {name ""}} { + my packInt32 [Const 0] $name } - # Builder:listRange(STRING,INT,INT) -- + # Builder:listRange(LIST,INT,INT) -- + # + # Get a sublist of a list. Quadcode implementation ('listRange'). + # + # Parameters: + # value - List value to get a substring of, in an LLVM LIST reference. + # from - Index of first element to return, in an LLVM INT reference. + # to - Index of last element to return, in an LLVM INT reference. + # ec - Location to write the Tcl return code into, as an LLVM int* + # reference. (Ignored.) + # name (optional) - + # A name to give to the result value. + # + # Results: + # The sublist, as an LLVM LIST FAIL reference. + + method listRange(LIST,INT,INT) {value from to ec {name ""}} { + my call ${tcl.list.range1} [list $value $from $to] $name + } + method listRange(EMPTY,INT,INT) {value from to c {name ""}} { + my call ${tcl.list.range1} [list $value $from $to] $name + } + + # Builder:listRange(LIST,STRING,STRING) -- # # Get a sublist of a list. NOTE: this operation can fail (e.g., because # it can be given an invalid list) so it produces a STRING FAIL. # Quadcode implementation ('listRange'). # # Parameters: - # value - List value to get a substring of, in an LLVM STRING reference. - # from - Index of first element to return, in an LLVM INT reference. - # to - Index of last element to return, in an LLVM INT reference. - # errVar - - # Location to write the Tcl return code into, as an LLVM int* - # reference. - # name (optional) - - # A name to give to the result value. - # - # Results: - # The sublist, as an LLVM STRING FAIL reference. - - method listRange(STRING,INT,INT) {value from to ec {name ""}} { - my call ${tcl.list.range1} [list $value $from $to $ec] $name - } - - # Builder:listRange(STRING,STRING,STRING) -- - # - # Get a sublist of a list. NOTE: this operation can fail (e.g., because - # it can be given an invalid list) so it produces a STRING FAIL. - # Quadcode implementation ('listRange'). - # - # Parameters: - # value - List value to get a substring of, in an LLVM STRING reference. + # value - List value to get a substring of, in an LLVM LIST reference. # from - Index of first element to return, in an LLVM STRING reference. # to - Index of last element to return, in an LLVM STRING reference. - # errVar - - # Location to write the Tcl return code into, as an LLVM int* + # ec - Location to write the Tcl return code into, as an LLVM int* # reference. # name (optional) - # A name to give to the result value. # # Results: - # The sublist, as an LLVM STRING FAIL reference. + # The sublist, as an LLVM LIST FAIL reference. - method listRange(STRING,STRING,STRING) {value from to ec {name ""}} { + method listRange(LIST,STRING,STRING) {value from to ec {name ""}} { + my call ${tcl.list.range} [list $value $from $to $ec] $name + } + method listRange(EMPTY,STRING,STRING) {value from to ec {name ""}} { my call ${tcl.list.range} [list $value $from $to $ec] $name } - # Builder:listSet(STRING,STRING) -- + # Builder:listSet(LIST,STRING) -- # # Update an element in a sublist of a list. NOTE: this operation can - # fail (e.g., because it can be given an invalid list) so it produces a - # STRING FAIL. Quadcode implementation ('listSet'). + # fail (e.g., because it can be given an invalid index) so it produces a + # LIST FAIL. Quadcode implementation ('listSet'). # # Parameters: - # list - List value to get a substring of, in an LLVM STRING reference. + # list - List value to get a substring of, in an LLVM LIST reference. # elem - The value to write into the list, in an LLVM STRING reference. # vector - # The indices as an LLVM vector value reference. # ecvar - Location to write the Tcl return code into, as an LLVM int* # reference. # name (optional) - # A name to give to the result value. # # Results: - # The updated list, as an LLVM STRING FAIL reference. + # The updated list, as an LLVM LIST FAIL reference. - method listSet(STRING,STRING) {list elem vector ecvar {name ""}} { + method listSet(LIST,STRING) {list elem vector ecvar {name ""}} { + my ExtractVector $vector + my call ${tcl.list.set} [list $list $len $ary $elem $ecvar] $name + } + method listSet(EMPTY,STRING) {list elem vector ecvar {name ""}} { my ExtractVector $vector my call ${tcl.list.set} [list $list $len $ary $elem $ecvar] $name } - # Builder:listSet(STRING,INT,STRING) -- + # Builder:listSet(LIST,INT,STRING) -- # # Update an element of a list. NOTE: this operation can fail (e.g., - # because it can be given an invalid list) so it produces a STRING FAIL. + # because it can be given an invalid index) so it produces a LIST FAIL. # Quadcode implementation ('listSet'). # # Parameters: - # list - List value update, in an LLVM STRING reference. + # list - List value update, in an LLVM LIST reference. # idx - The index into the list to set, in an LLVM INT reference. # elem - The value to write into the list, in an LLVM STRING reference. # ecvar - Location to write the Tcl return code into, as an LLVM int* # reference. # name (optional) - # A name to give to the result value. # # Results: - # The updated list, as an LLVM STRING FAIL reference. + # The updated list, as an LLVM LIST FAIL reference. - method listSet(STRING,INT,STRING) {list idx elem ecvar {name ""}} { + method listSet(LIST,INT,STRING) {list idx elem ecvar {name ""}} { + my call ${tcl.list.set1} [list $list $idx $elem $ecvar] $name + } + method listSet(EMPTY,INT,STRING) {list idx elem ecvar {name ""}} { my call ${tcl.list.set1} [list $list $idx $elem $ecvar] $name } - # Builder:listSet(STRING,STRING,STRING) -- + # Builder:listSet(LIST,STRING,STRING) -- # # Update an element of a list or sublist. NOTE: this operation can fail - # (e.g., because it can be given an invalid list) so it produces a - # STRING FAIL. Quadcode implementation ('listSet'). + # (e.g., because it can be given an invalid index) so it produces a LIST + # FAIL. Quadcode implementation ('listSet'). # # Parameters: - # list - List value update, in an LLVM STRING reference. + # list - List value update, in an LLVM LIST reference. # idx - The index into the list to set, in an LLVM STRING reference. # elem - The value to write into the list, in an LLVM STRING reference. # ecvar - Location to write the Tcl return code into, as an LLVM int* # reference. # name (optional) - # A name to give to the result value. # # Results: - # The updated list, as an LLVM STRING FAIL reference. + # The updated list, as an LLVM LIST FAIL reference. - method listSet(STRING,STRING,STRING) {list idx elem ecvar {name ""}} { + method listSet(LIST,STRING,STRING) {list idx elem ecvar {name ""}} { + my call ${tcl.list.setList} [list $list $idx $elem $ecvar] $name + } + method listSet(EMPTY,STRING,STRING) {list idx elem ecvar {name ""}} { my call ${tcl.list.setList} [list $list $idx $elem $ecvar] $name } # Builder:lor(INT,INT) -- # @@ -5547,10 +5663,66 @@ } elseif {[string match "NEXIST *" $type]} { set type [string range $type 7 end] } my insert [my undef $type!] [Const true bool] 0 $name } + + # Builder:narrowToType.DICT(STRING) -- + # + # Generate code to parse the given STRING and extract a DICT. The + # STRING is already be known to contain a value of the right type (due + # to higher-level quadcode constraints). Quadcode implementation + # ('narrowToType'). + # + # Parameters: + # value - The STRING LLVM value reference to parse. + # name (optional) - + # A name to give to the result value. + # + # Results: + # A DICT LLVM value reference. + + method narrowToType.DICT(STRING) {value {name ""}} { + return $value + } + method narrowToType.IMPURE_DICT(STRING) {value {name ""}} { + return $value + } + method narrowToType.EMPTY_DICT(STRING) {value {name ""}} { + return $value + } + method narrowToType.IMPURE_EMPTY_DICT(STRING) {value {name ""}} { + return $value + } + + # Builder:narrowToType.LIST(STRING) -- + # + # Generate code to parse the given STRING and extract a LIST. The + # STRING is already be known to contain a value of the right type (due + # to higher-level quadcode constraints). Quadcode implementation + # ('narrowToType'). + # + # Parameters: + # value - The STRING LLVM value reference to parse. + # name (optional) - + # A name to give to the result value. + # + # Results: + # A LIST LLVM value reference. + + method narrowToType.LIST(STRING) {value {name ""}} { + return $value + } + method narrowToType.IMPURE_LIST(STRING) {value {name ""}} { + return $value + } + method narrowToType.EMPTY_LIST(STRING) {value {name ""}} { + return $value + } + method narrowToType.IMPURE_EMPTY_LIST(STRING) {value {name ""}} { + return $value + } # Builder:unmaybe -- # # Get the value out of a FAIL or NEXIST. NOTE: The FAIL/NEXIST must be a # Just or the result will be an 'undef'; test with the 'maybe' method @@ -6099,10 +6271,74 @@ method packImpure(NUMERIC) {value {name ""}} { set sval [my stringify(NUMERIC) $value] my addReference(STRING) $sval return [my impure NUMERIC $sval $value $name] } + + # Builder:packImpure(DICT) -- + # + # Convert a DICT to an IMPURE DICT + # + # Parameters: + # value - LLVM Value to pack into the 'impure' structure + # name (optional) - + # A name to give to the result value. + # + # Results: + # Returns an LLVM IMPURE DICT value + + method packImpure(DICT) {value {name ""}} { + return $value + } + + # Builder:packImpure(EMPTY DICT) -- + # + # Convert an EMPTY DICT to an IMPURE EMPTY DICT + # + # Parameters: + # value - LLVM Value to pack into the 'impure' structure + # name (optional) - + # A name to give to the result value. + # + # Results: + # Returns an LLVM IMPURE DICT value + + method packImpure(EMPTY\040DICT) {value {name ""}} { + return $value + } + + # Builder:packImpure(EMPTY LIST) -- + # + # Convert an EMPTY LIST to an IMPURE EMPTY LIST + # + # Parameters: + # value - LLVM Value to pack into the 'impure' structure + # name (optional) - + # A name to give to the result value. + # + # Results: + # Returns an LLVM IMPURE LIST value + + method packImpure(EMPTY\040LIST) {value {name ""}} { + return $value + } + + # Builder:packImpure(LIST) -- + # + # Convert a LIST to an IMPURE LIST + # + # Parameters: + # value - LLVM Value to pack into the 'impure' structure + # name (optional) - + # A name to give to the result value. + # + # Results: + # Returns an LLVM IMPURE LIST value + + method packImpure(LIST) {value {name ""}} { + return $value + } # Builder:packImpure(ZEROONE BOOLEAN) -- # # Convert a ZEROONE BOOLEAN to an IMPURE ZEROONE BOOLEAN # Index: codegen/compile.tcl ================================================================== --- codegen/compile.tcl +++ codegen/compile.tcl @@ -39,10 +39,13 @@ namespace eval tcl { namespace eval mathfunc { proc literal {descriptor} { string equal [lindex $descriptor 0] "literal" } + proc var {descriptor} { + string equal [lindex $descriptor 0] "var" + } proc refType {type} { expr { [uplevel 1 [list my ReferenceType? $type]] && "CALLFRAME" ni $type } @@ -56,10 +59,16 @@ proc consumed {var search} { uplevel 1 [list my IsConsumed $var $search] } proc callframe {operand} { uplevel 1 [list my IsCallFrame $operand] + } + proc maybetype {operand type} { + uplevel 1 [list my MayBeType $operand $type] + } + proc impure {type} { + expr {"IMPURE" in $type} } } } } @@ -130,23 +139,27 @@ # None. method PrintTypedQuads {channel qs} { set idx -1 set descriptions [lmap q $qs { - concat "[incr idx]:" $q ":" [linsert [lmap arg [lrange $q 1 end] { - try { - if {$arg eq ""} { - string cat VOID - } elseif {[string match {pc *} $arg]} { - string cat BLOCK - } else { - my ValueTypes $arg - } - } on error {} { - string cat VOID - } - }] 1 \u21d0] + if {[string match @debug-* [lindex $q 0]]} { + concat "[incr idx]:" $q + } else { + concat "[incr idx]:" $q ":" [linsert [lmap arg [lrange $q 1 end] { + try { + if {$arg eq ""} { + string cat VOID + } elseif {[string match {pc *} $arg]} { + string cat BLOCK + } else { + my ValueTypes $arg + } + } on error {} { + string cat VOID + } + }] 1 "\u21d0"] + } }] if {$channel eq ""} { return [format "%s------>\n%s" $cmd [join $descriptions \n]] } else { puts $channel [format "%s------>\n%s" $cmd [join $descriptions \n]] @@ -247,10 +260,11 @@ $block(-1) build-in $b $b @location 0 set errorCode [$b alloc int "tcl.errorCode"] set curr_block $block(-1) set 0 [$b int 0] + $b store [Const 0 int] $errorCode ############################################################## # # Create debug info for variables in LLVM @@ -260,11 +274,11 @@ # Make the debugging information for the variable provided it is a # variable as perceived from the Tcl level. "Internal" temporary # variables aren't nearly so interesting. - if {$kind eq "var"} { + if {var($name)} { if {[lindex $quads $origin 0] eq "param"} { set idx [lsearch $bytecodeVars \ [list "scalar arg" $formalname]] if {$idx < 0} { return -code error \ @@ -366,11 +380,11 @@ set var [my LoadTypedLiteral $defaultvalue $type] } else { set var [$func param $idx $name] } set variables($tgt) $var - if {[regexp {^IMPURE } $type]} { + if {impure($type) && "LIST" ni $type && "DICT" ni $type} { set var [$b stringifyImpure $var] set type STRING } if {refType($type)} { $b printref $var "param:" @@ -383,11 +397,11 @@ if {callframe($src)} { foreach {name value} $mapping { set name [lindex $name 1] set var [dict get $thevarmap $name] if {$value ne "Nothing"} { - set op frame.store([my ValueTypes $value]) + set op frame.store([my OperandType $value]) set value [my LoadOrLiteral $value] $b $op $value $theframe $var $name } else { $b frame.unset $theframe $var $name } @@ -395,13 +409,13 @@ } my StoreResult $tgt [my LoadOrLiteral $src] } "retrieveResult" { lassign $l opcode tgt src - if {[my ValueTypes $src] eq "CALLFRAME"} { + if {operandType($src) eq "CALLFRAME"} { set value [$b undef NOTHING] - } elseif {"CALLFRAME" in [my ValueTypes $src]} { + } elseif {callframe($src)} { set value [$b frame.value [my LoadOrLiteral $src]] } else { set value [my LoadOrLiteral $src] my Warn "retrieveResult from non-callframe" } @@ -409,11 +423,11 @@ } "extractCallFrame" { lassign $l opcode tgt src if {callframe($src)} { set value [my LoadOrLiteral $src] - if {[my ValueTypes $src] ne "CALLFRAME"} { + if {operandType($src) ne "CALLFRAME"} { set name [my LocalVarName $tgt] set value [$b frame.frame $value $name] } } else { set value $theframe @@ -431,11 +445,11 @@ } } "result" { lassign $l opcode tgt src set name [my LocalVarName $tgt] - append opcode ( [my ValueTypes $src] ) + append opcode ( [my OperandType $src] ) set src [my LoadOrLiteral $src] my StoreResult $tgt [$b $opcode $src $name] } "returnOptions" { lassign $l opcode tgt src ecode @@ -446,11 +460,11 @@ my StoreResult $tgt [$b $opcode {*}$srcs $name] } "nsupvar" - "upvar" - "variable" { set srcs [lassign $l opcode tgt src] set localvar [lindex $srcs 0] - if {[lindex $localvar 0] ne "literal"} { + if {!literal($localvar)} { error "local variable must be literal" } set name [my LocalVarName $tgt] set var [dict get $thevarmap [lindex $localvar 1]] set op [dict get { @@ -459,11 +473,11 @@ variable frame.bind.var } $opcode] append op ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $op {*}$srcs $var $theframe $errorCode $name] - if {"FAIL" in [my ValueTypes $tgt]} { + if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode \ [$b maybe [$b frame.value $res]] } my StoreResult $tgt $res } @@ -487,11 +501,11 @@ set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $errorCode $name] - if {"FAIL" in [my ValueTypes $tgt]} { + if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $res] } my StoreResult $tgt $res } "list" { @@ -504,21 +518,21 @@ "strindex" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] set srcs [my ConvertIndices 0 strlen 1] set res [$b $opcode {*}$srcs $errorCode $name] - if {"FAIL" in [my ValueTypes $tgt]} { + if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $res] } my StoreResult $tgt $res } "strrange" - "strreplace" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] set srcs [my ConvertIndices 0 strlen 1 2] set res [$b $opcode {*}$srcs $errorCode $name] - if {"FAIL" in [my ValueTypes $tgt]} { + if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $res] } my StoreResult $tgt $res } "directGet" - "directSet" - "directAppend" - "directLappend" - @@ -533,48 +547,54 @@ "dictGetOrNexist" - "dictSetOrUnset" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] - set res [$b $opcode {*}$srcs $errorCode $name] - if {"FAIL" in [my ValueTypes $tgt]} { + if {"FAIL" in operandType($tgt)} { + set res [$b $opcode {*}$srcs $errorCode $name] my SetErrorLine $errorCode [$b maybe $res] + } else { + set res [$b $opcode {*}$srcs $name] } my StoreResult $tgt $res } "listAppend" - "listConcat" - "listRange" { set srcs [lassign $l opcode tgt] set src1 [lindex $srcs 0] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] + set canFail [expr {"FAIL" in operandType($tgt)}] + set ec [if {$canFail} {list $errorCode}] if {consumed($src1, $pc + 1)} { - set res [$b $opcode {*}$srcs $errorCode $name] + $b printref [lindex $srcs 0] "[lindex $l 0 0]:A:" + set res [$b $opcode {*}$srcs {*}$ec $name] } else { - $b addReference([my ValueTypes $src1]) [lindex $srcs 0] - set res [$b $opcode {*}$srcs $errorCode $name] - $b dropReference([my ValueTypes $src1]) [lindex $srcs 0] + $b printref [lindex $srcs 0] "[lindex $l 0 0]:B:" + $b addReference([my OperandType $src1]) [lindex $srcs 0] + set res [$b $opcode {*}$srcs {*}$ec $name] + $b dropReference([my OperandType $src1]) [lindex $srcs 0] } - if {"FAIL" in [my ValueTypes $tgt]} { + if {$canFail} { my SetErrorLine $errorCode [$b maybe $res] } my StoreResult $tgt $res } "returnCode" { lassign $l opcode tgt src set name [my LocalVarName $tgt] - append opcode ( [my ValueTypes $src] ) + append opcode ( [my OperandType $src] ) my StoreResult $tgt \ [$b $opcode [my LoadOrLiteral $src] \ [$b load $errorCode] $name] } "initException" { my IssueException $l } "setReturnCode" { lassign $l opcode tgt src - append opcode ( [my ValueTypes $src] ) + append opcode ( [my OperandType $src] ) my StoreResult $tgt \ [$b $opcode [my LoadOrLiteral $src] $errorCode] } "procLeave" { set srcs [lassign $l opcode tgt] @@ -592,28 +612,54 @@ if {[llength $srcs] == 1} { # Simple case set srcs [list $srcObj {*}$srcs] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] - set res [$b $opcode {*}$srcs $errorCode $name] + set res [$b $opcode {*}$srcs $name] my StoreResult $tgt $res } else { # Need to construct the variadic path - set vectortypes [lmap s $srcs {my ValueTypes $s}] + set vectortypes [lmap s $srcs {my OperandType $s}] set vector [$b buildVector $objv $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] - append opcode ( [my ValueTypes $srcObj] ) + append opcode ( [my OperandType $srcObj] ) set srcObj [my LoadOrLiteral $srcObj] set res [$b $opcode $srcObj $vector $errorCode $name] my StoreResult $tgt $res $b clearVector $vector } - if {"FAIL" in [my ValueTypes $tgt]} { + if {"FAIL" in operandType($tgt)} { + my SetErrorLine $errorCode [$b maybe $res] + } + } + "dictSet" { + set srcs [lassign $l opcode tgt srcObj srcValue] + set name [my LocalVarName $tgt] + if {[llength $srcs] == 1} { + # Simple case + set srcs [list $srcObj {*}$srcs $srcValue] + append opcode ( [my ValueTypes {*}$srcs] ) + set srcs [lmap s $srcs {my LoadOrLiteral $s}] + set res [$b $opcode {*}$srcs $name] + my StoreResult $tgt $res + } else { + # Need to construct the variadic path + set vectortypes [lmap s $srcs {my OperandType $s}] + set vector [$b buildVector $objv $vectortypes \ + [lmap s $srcs {my LoadOrLiteral $s}]] + set srcs [list $srcObj $srcValue] + append opcode ( [my ValueTypes {*}$srcs] ) + set srcs [lmap s $srcs {my LoadOrLiteral $s}] + set res [$b $opcode {*}$srcs $vector $errorCode $name] + my StoreResult $tgt $res + $b clearVector $vector + } + if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $res] } } - "dictSet" - "listSet" { + "listSet" { set srcs [lassign $l opcode tgt srcObj srcValue] set name [my LocalVarName $tgt] if {[llength $srcs] == 1} { # Simple case set srcs [list $srcObj {*}$srcs $srcValue] @@ -621,21 +667,21 @@ set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $errorCode $name] my StoreResult $tgt $res } else { # Need to construct the variadic path - set vectortypes [lmap s $srcs {my ValueTypes $s}] + set vectortypes [lmap s $srcs {my OperandType $s}] set vector [$b buildVector $objv $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] set srcs [list $srcObj $srcValue] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $vector $errorCode $name] my StoreResult $tgt $res $b clearVector $vector } - if {"FAIL" in [my ValueTypes $tgt]} { + if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $res] } } "copy" - "expand" { lassign $l opcode tgt src @@ -652,33 +698,36 @@ "maptoint" { lassign $l opcode tgt src map def set map [lindex $map 1] set def [lindex $def 1] set name [my LocalVarName $tgt] - append opcode ( [my ValueTypes $src] ) + append opcode ( [my OperandType $src] ) set src [my LoadOrLiteral $src] my StoreResult $tgt [$b $opcode $src $map $def $name] } "extractExists" - "extractMaybe" { my IssueExtract $l } "extractFail" { lassign $l opcode tgt src set name [my LocalVarName $tgt] - append opcode ( [my ValueTypes $src] ) + append opcode ( [my OperandType $src] ) set src [my LoadOrLiteral $src] my StoreResult $tgt [$b $opcode $src $name] } "purify" { lassign $l opcode tgt src set value [my LoadOrLiteral $src] - if {![regexp {^IMPURE} [my OperandType $src]]} { + set srctype [my OperandType $src] + if {!impure($srctype)} { return -code error \ "Trying to purify something that is not impure" } set name [my LocalVarName $tgt] - set value [$b impure.value $value $name] + if {"LIST" ni $srctype && "DICT" ni $srctype} { + set value [$b impure.value $value $name] + } set type [my OperandType $tgt] if {refType($type)} { $b addReference($type) $value $b printref $value "purify:" } @@ -690,16 +739,17 @@ if {$src ni $consumed} { if {$type eq "VOID"} { # VOID is trivial to free } elseif {refType($type)} { $b printref $variables($src) "free:" - if {"ARRAY" in [my ValueTypes $src]} { + set vt [my OperandType $src] + if {"ARRAY" in $vt} { # TRICKY POINT: need variable name to unset an array set name [Const [my LocalVarName $tgt] STRING] - $b dropReference([my ValueTypes $src]) $variables($src) $name + $b dropReference($vt) $variables($src) $name } else { - $b dropReference([my ValueTypes $src]) $variables($src) + $b dropReference($vt) $variables($src) } } lappend consumed $src } } @@ -743,29 +793,29 @@ } "jumpTrue" { lassign $l opcode tgt src set name [my LocalVarName $src] set tgt [lindex $tgt 1] - set mth isTrue([my ValueTypes $src]) + set mth isTrue([my OperandType $src]) set test [$b $mth [my LoadOrLiteral $src] test_$name] $b condBr $test $block($tgt) $ipath($pc) } "jumpFalse" { lassign $l opcode tgt src set name [my LocalVarName $src] set tgt [lindex $tgt 1] - set mth isTrue([my ValueTypes $src]) + set mth isTrue([my OperandType $src]) set test [$b $mth [my LoadOrLiteral $src] test_$name] $b condBr $test $ipath($pc) $block($tgt) } "jump" { $b br $block([lindex $l 1 1]) } "return" { lassign $l opcode -> frame src set val [my LoadOrLiteral $src] - if {"CALLFRAME" in [my ValueTypes $src]} { + if {callframe($src)} { # The CALLFRAME does not leave set val [$b frame.value $val] } set type [nameOfType $returnType] if {refType($type)} { @@ -827,11 +877,11 @@ } "frameArgs" { lassign $l opcode tgt src set name [my LocalVarName $tgt] set opcode frame.args - append opcode ( [my ValueTypes $src] ) + append opcode ( [my OperandType $src] ) set val [my LoadOrLiteral $src] set result [$b $opcode $val $theframe $name] my StoreResult $tgt $result } "frameDepth" { @@ -855,41 +905,41 @@ set result [$b unshareCopy($type) $val $name] } $b printref $result "cat:" foreach src $srcs { set val [my LoadOrLiteral $src] - $b appendString([my ValueTypes $src]) $val $result + $b appendString([my OperandType $src]) $val $result } my StoreResult $tgt $result } "concat" { set srcs [lassign $l opcode tgt] # Need to construct the variadic vector - set vectortypes [lmap s $srcs {my ValueTypes $s}] + set vectortypes [lmap s $srcs {my OperandType $s}] set vector [$b buildVector $objv $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] set name [my LocalVarName $tgt] set result [$b concat() $vector $name] my StoreResult $tgt $result $b clearVector $vector } "foreachStart" { set srcs [lassign $l opcode tgt assign] - set listtypes [lmap s $srcs {my ValueTypes $s}] + set listtypes [lmap s $srcs {my OperandType $s}] set lists [lmap s $srcs {my LoadOrLiteral $s}] set result [$b foreachStart \ [lindex $assign 1] $lists \ $listtypes $errorCode] - if {"FAIL" in [my ValueTypes $tgt]} { + if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $result] } my StoreResult $tgt $result } "unshareList" { lassign $l opcode tgt src set name [my LocalVarName $tgt] - append opcode ( [my ValueTypes $src] ) + append opcode ( [my OperandType $src] ) set result [$b $opcode [my LoadOrLiteral $src] $name] my StoreResult $tgt $result } "foreachIter" - "foreachAdvance" - "foreachMayStep" - "dictIterKey" - "dictIterValue" - "dictIterDone" - @@ -1148,11 +1198,11 @@ set arguments [list [list literal $cmd]] foreach vinfo $varmeta { if {"arg" in [lindex $vinfo 0]} { set vname [list var [lindex $vinfo 1] [llength $arguments]] lappend arguments $vname - lappend argtypes [my ValueTypes $vname] + lappend argtypes [my OperandType $vname] } } # Patch in the extra variables discovered during quadcode analysis; # these are never arguments as Tcl always correctly puts those in the @@ -1263,22 +1313,22 @@ method IssueInvokeFunction {tgt func arguments vname} { upvar 1 callframe callframe thecallframe thecallframe set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING} set result [$b call $func $arguments $vname] - if {[my ValueTypes $tgt] eq "FAIL"} { + if {operandType($tgt) eq "FAIL"} { $b store $result $errorCode my SetErrorLine $errorCode } else { set ts [lmap t $BASETYPES {Type $t?}] if {[TypeOf $result] in $ts} { $b store [$b extract $result 0] $errorCode - } elseif {[Type [TypeOf $result]?] eq [Type [my ValueTypes $tgt]]} { + } elseif {[Type [TypeOf $result]?] eq [Type [my OperandType $tgt]]} { # Managed to prove non-failure in this case... set result [$b ok $result] } - if {"FAIL" in [my ValueTypes $tgt]} { + if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $result] } } if {callframe($thecallframe)} { @@ -1288,11 +1338,11 @@ } method IssueInvokeCommand {tgt resolved arguments argvals vname} { upvar 1 callframe callframe thecallframe thecallframe - set types [lmap s $arguments {my ValueTypes $s}] + set types [lmap s $arguments {my OperandType $s}] if {$resolved ne ""} { # FIXME: this causes wrong "wrong # args" messages set argvals [lreplace $argvals 0 0 $resolved] } set vector [$b buildVector $objv $types $argvals] @@ -1328,11 +1378,11 @@ set vname [my LocalVarName $tgt] set expandPositions [lmap s $arguments { expr {"EXPANDED" in [my OperandType $s]} }] set argvals [lmap s $arguments {my LoadOrLiteral $s}] - set types [lmap s $arguments {my ValueTypes $s}] + set types [lmap s $arguments {my OperandType $s}] set vector [$b buildVector $objv $types $argvals] set flags [$b buildBitArray $bitv $expandPositions] set result [$b invokeExpanded $vector $flags $errorCode $vname] my SetErrorLine $errorCode [$b maybe $result] if {callframe($thecallframe)} { @@ -1356,11 +1406,11 @@ # none method IssueWiden {operation} { lassign $operation opcode tgt src set name [my LocalVarName $tgt] - set srctype [my ValueTypes $src] + set srctype [my OperandType $src] set tgttype [lindex $opcode 2] if {$tgttype eq ""} { set tgttype [my OperandType $tgt] } if {$srctype in {"VOID" "NOTHING" "NEXIST"}} { @@ -1371,11 +1421,11 @@ } "NEXIST *" { set t [lrange $tgttype 1 end] set value [$b nothing $t $name] } - "STRING" - "EMPTY" { + "STRING" - "LIST" - "DICT" - "EMPTY" { set value [my LoadOrLiteral "literal {}"] } default { # Should be unreachable in practice my Warn "widened void to %s; result is undef" $tgttype @@ -1413,10 +1463,11 @@ error "callframe injection" } # Handle FAIL-extended types if {"FAIL" eq $srctype && "FAIL" in $tgttype} { + my Warn "widen FAIL (%s) to %s" [PrintValueToString $value] $tgttype # Implementation type of pure FAIL is int32 (Tcl result code) set tgttype [lrange $tgttype 1 end] return [$b fail $tgttype $value] } elseif {"FAIL" in $srctype && "FAIL" in $tgttype} { set value [$b unmaybe $value] @@ -1466,23 +1517,28 @@ set svalue [my WidenedValue $value $srctype STRING] set tuple [$b arraystring.from.scalar $svalue] } return $tuple } + + # Variations of LIST and DICT go straight to STRING + + if {"STRING" in $tgttype && ("LIST" in $srctype || "DICT" in $srctype)} { + return $value + } # IMPURE to IMPURE - Copy the string value, and promote the # inner value - if {[lindex $tgttype 0] eq "IMPURE" - && [lindex $srctype 0] eq "IMPURE"} { + if {impure($tgttype) && impure($srctype)} { set itgttype [lrange $tgttype 1 end] set isrctype [lrange $srctype 1 end] set ivalue [my WidenedValue [$b impure.value $value] \ $isrctype $itgttype] set svalue [$b impure.string $value] set value [$b impure $itgttype $svalue $ivalue $name] - } elseif {[lindex $srctype 0] eq "IMPURE" && "STRING" in $tgttype} { + } elseif {impure($srctype) && "STRING" in $tgttype} { set value [$b stringifyImpure $value $name] } elseif {[regexp {^IMPURE (.*)$} $tgttype -> innertype]} { set widened [my WidenedValue $value $srctype $innertype] set value [$b packImpure($innertype) $widened $name] } elseif {$tgttype eq "ZEROONE BOOLEAN"} { @@ -1503,17 +1559,18 @@ } else { set value [$b packNumericInt $value $name] } } elseif {$srctype eq "EMPTY" && $tgttype eq "STRING"} { set value [Const "" STRING] - } elseif {$srctype ne $tgttype} { - my Warn "unimplemented convert from '%s' to '%s'" $srctype $tgttype } if {[Type $tgttype] eq [Type [TypeOf $value]?]} { set value [$b ok $value] } elseif {[Type $tgttype] eq [Type [TypeOf $value]!]} { set value [$b just $value] + } elseif {[Type $srctype] ne [Type $tgttype]} { + # If the types didn't end up matching, we're in deep trouble now... + my Warn "unimplemented convert from '%s' to '%s'" $srctype $tgttype } return $value } # TclCompiler:IssueDictExists -- @@ -1550,15 +1607,15 @@ my StoreResult $tgt [my LoadOrLiteral "literal 0"] return } # Need to construct the variadic vector - set types [lmap s $srcs {my ValueTypes $s}] + set types [lmap s $srcs {my OperandType $s}] set vector [$b buildVector $objv $types \ [lmap s $srcs {my LoadOrLiteral $s}]] set name [my LocalVarName $tgt] - append opcode ( [my ValueTypes $srcDict] ) + append opcode ( [my OperandType $srcDict] ) set srcDict [my LoadOrLiteral $srcDict] my StoreResult $tgt [$b $opcode $srcDict $vector $name] $b clearVector $vector return } @@ -1684,11 +1741,11 @@ method IssueException {operation} { upvar 1 errorCode errorCode set srcs [lassign $operation opcode tgt src] set src2 [lindex $srcs 0] - set maintype [my ValueTypes $src] + set maintype [my OperandType $src] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set value [my LoadOrLiteral $src] # Check if we can issue more efficient code by understanding the @@ -1821,12 +1878,31 @@ # A Tcl boolean value. method IsCallFrame {operand} { variable ::quadcode::dataType::CALLFRAME - return [expr {[lindex $operand 0] in {"var" "temp"} - && ([typeOfOperand $vtypes $operand] & $CALLFRAME) != 0}] + return [expr { + !literal($operand) + && ([typeOfOperand $vtypes $operand] & $CALLFRAME) != 0 + }] + } + + # TclCompiler:MayBeBasicType -- + # + # Get whether a particular operand may be of a particular type. + # + # Parameters: + # operand - + # The operand to test the type of. + # type - The name of the type (see quadcode/types.tcl) + # + # Results: + # A Tcl boolean value. + + method MayBeBasicType {operand type} { + namespace upvar ::quadcode::dataType $type typecode + return [expr {([typeOfOperand $vtypes $operand] & $typecode) != 0}] } # TclCompiler:ValueTypes -- # # Convert the sequence of arguments (to an opcode) into the type @@ -1906,14 +1982,14 @@ } if {$desc eq "Nothing"} { # NEXIST special case return "Nothing" } - lassign $desc kind value - if {$kind ne "literal"} { + if {!literal($desc)} { return -code error "unsubstitutable argument: $desc" } + lassign $desc -> value set type [nameOfType [typeOfLiteral $value]] return [my LoadTypedLiteral $value $type] } # TclCompiler:LoadTypedLiteral -- @@ -1932,22 +2008,25 @@ # DO NOT do reference count management in this function! It makes things # leak or triggers use-after-free crashes. Leave that to the main # compiler engine (and the STRING allocator) as that gets it right. method LoadTypedLiteral {value type} { - if {[lindex $type 0] eq "IMPURE"} { + if {impure($type)} { set sval [my LoadTypedLiteral $value STRING] set itype [lrange $type 1 end] + if {$itype in {LIST DICT {EMPTY LIST} {EMPTY DICT}}} { + return $sval + } set tval [my LoadTypedLiteral $value $itype] return [$b impure $itype $sval $tval] } elseif {$type eq "DOUBLE"} { return [ConstReal [Type $type] $value] } elseif {$type in {"ZEROONE" "BOOLEAN" "ZEROONE BOOLEAN"}} { return [Const [expr {$value}] bool] } elseif {$type in {"INT" "ENTIER"}} { return [$b int [expr {entier($value)}]] - } elseif {$type in {"STRING" "EMPTY"}} { + } elseif {$type in {"STRING" "LIST" "DICT" "EMPTY" "EMPTY LIST" "EMPTY DICT"}} { set result [Const $value STRING] $b assume [$b shared $result] return $result } else { return -code error \ @@ -1980,11 +2059,11 @@ method StoreResult {desc value {opcode ""}} { upvar 1 phiAnnotations phiAnnotations # Validate that the destination is indeed a variable or temporary - if {[lindex $desc 0] ni {"var" "temp"}} { + if {literal($desc)} { return -code error "cannot store into $desc; it makes no sense" } # Validate that SSA form has been preserved if {[info exists variables($desc)]} { @@ -1996,11 +2075,11 @@ if {[Type $destType] ne [TypeOf $value]} { my Warn "Attempt to store the value '%s' into a variable, '%s', of type '%s'" \ [PrintValueToString $value] $desc $destType } - if {[lindex $desc 0] eq "var"} { + if {var($desc)} { if {[lindex $opcode 0] eq "phi"} { lappend phiAnnotations [lindex $desc 1] $value } else { my AnnotateAssignment [lindex $desc 1] $value } @@ -2048,11 +2127,11 @@ method ReferenceType? {type} { if {[string is entier -strict $type]} { set type [nameOfType $type] } foreach piece $type { - if {$piece in {IMPURE DICTITER EMPTY STRING ENTIER ARRAY}} { + if {$piece in {IMPURE DICTITER EMPTY STRING ENTIER ARRAY LIST DICT}} { return 1 } } return 0 } @@ -2188,14 +2267,14 @@ # # Results: # The Tcl value inside the quadcode value. method LiteralValue {qcval} { - lassign $qcval key value - if {$key ne "literal"} { + if {!literal($qcval)} { return -code error "assumption that '$qcval' is literal not met" } + lassign $qcval -> value return $value } } # Class TclInterproceduralCompiler -- Index: codegen/stdlib.tcl ================================================================== --- codegen/stdlib.tcl +++ codegen/stdlib.tcl @@ -38,11 +38,11 @@ # 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.step variable tcl.list.foreach.start.finish tcl.list.unshare - variable tcl.list.range tcl.list.range1 tcl.list.in + variable tcl.list.range tcl.list.range1 tcl.list.in tcl.isList variable tcl.list.index tcl.list.index1 tcl.list.indexList variable tcl.list.set tcl.list.set1 tcl.list.setList tcl.list.verify # Variables holding implementations of Tcl's dict operators variable tcl.dict.get1 tcl.dict.get tcl.dict.set1 tcl.dict.set @@ -50,11 +50,11 @@ variable tcl.dict.iterStart tcl.dict.iterNext tcl.dict.iterDone variable tcl.dict.iterKey tcl.dict.iterValue tcl.dict.addIterReference variable tcl.dict.addIterFailReference variable tcl.dict.dropIterReference tcl.dict.dropIterFailReference variable tcl.dict.append tcl.dict.lappend tcl.dict.incr tcl.dict.size - variable tcl.dict.get1.empty tcl.dict.set1.empty + variable tcl.dict.get1.empty tcl.dict.set1.empty tcl.isDict variable tcl.maptoint # Variables holding implementations of Tcl's exception-handling machinery variable tcl.getresult tcl.getreturnopts tcl.initExceptionOptions variable tcl.initExceptionSimple tcl.processReturn tcl.procedure.return @@ -178,12 +178,12 @@ # object is supplied set f [$m local "tcl.addFailReference" void<-Tcl_Obj*?] params value:maybeObjPtr build { - my condBr [my maybe $value] $nothing $incr - label incr "action.required" + my condBr [my maybe $value] $incr $nothing + label incr "action.required.afr" set value [my unmaybe $value "objPtr"] $api Tcl_IncrRefCount $value my ret label nothing "nothing.to.do" my ret @@ -197,11 +197,11 @@ # reference, and delete it if the reference count drops to zero. set f [$m local "tcl.dropFailReference" void<-Tcl_Obj*?] params value:maybeObjPtr build { - my condBr [my maybe $value] $nothing $decr + my condBr [my maybe $value] $decr $nothing label decr "action.required" set value [my unmaybe $value "objPtr"] $api Tcl_DecrRefCount $value my ret label nothing "nothing.to.do" @@ -296,11 +296,11 @@ # reference, and delete it if the reference count drops to zero. set f [$m local "tcl.dropFailNExistReference" void<-Tcl_Obj*!?] params value:maybeObjPtr build { - my condBr [my maybe $value] $nothing $decr + my condBr [my maybe $value] $decr $nothing label decr "action.required" my Call tcl.dropNExistReference [my unmaybe $value] my ret label nothing "nothing.to.do" my ret @@ -494,21 +494,22 @@ set str [$api Tcl_ObjPrintf [my constString "%d:NULL\n"] $pr] $api Tcl_WriteObj $chan $str $api Tcl_DecrRefCount $str my ret } - set f [$m local writeref? void<-int,STRING?,char*] + set f [$m local writeref? void<-int,STRING?,char* noinline] 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 Call writeref $pr {} $prefix my ret } - set f [$m local writearef void<-int,ARRAY,char*] + set f [$m local writearef void<-int,ARRAY,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 @@ -689,16 +690,16 @@ } ##### Function tcl.isPureByteArray ##### ##### Closure Build:isByteArray ##### # - # Type signature: objPtr:STRING -> int1 + # Type signature: objPtr:STRING -> bool # # 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] + set f [$m local "tcl.isPureByteArray" bool<-STRING readonly] params objPtr build { nonnull $objPtr set baType [$api tclByteArrayType] set typePtr [my dereference $objPtr 0 Tcl_Obj.typePtr] @@ -716,16 +717,16 @@ } ##### Function tcl.isUnicodeString ##### ##### Closure Build:isUnicodeString ##### # - # Type signature: objPtr:STRING -> int1 + # Type signature: objPtr:STRING -> bool # # 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] + set f [$m local "tcl.isUnicodeString" bool<-STRING readonly] params objPtr build { nonnull $objPtr set strType [$api tclStringType] set type [my dereference $objPtr 0 Tcl_Obj.typePtr] @@ -736,20 +737,20 @@ } ##### Function tcl.impl.getBoolean ##### ##### MAPPED CALL TO METHOD: Build:GetBoolean ##### # - # Type signature: valueObj:STRING -> int1*int1 + # Type signature: valueObj:STRING -> bool*bool - set f [$m local "tcl.impl.getBoolean" struct{int1,int1}<-STRING] + set f [$m local "tcl.impl.getBoolean" struct{bool,bool}<-STRING] params valueObj build { nonnull $valueObj set boolVar [my alloc int32 "boolPtr"] set str [$api Tcl_GetString $valueObj] set code [$api Tcl_GetBooleanFromObj {} $valueObj $boolVar] - set res [my undef struct{int1,int1}] + set res [my undef struct{bool,bool}] set res [my insert $res [my eq $code [Const 0]] 0] set res \ [my insert $res [my neq [my load $boolVar "bool"] [Const 0]] 1] my ret $res } @@ -765,20 +766,20 @@ # 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] + set f [$m local "tcl.impl.getDouble" struct{bool,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 undef struct{bool,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 @@ -789,11 +790,11 @@ # Type signature: valueObj:STRING -> bool * 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] + set f [$m local "tcl.impl.getWide" struct{bool,int64}<-STRING] my closure GetWide {valueObj {name "result"}} { my call ${tcl.impl.getWide} [list $valueObj] $name } params valueObj build { @@ -1093,11 +1094,11 @@ } ##### Function tcl.impl.isAscii ##### # Replacement for non-exposed UniCharIsAscii # - # Type signature: ch:int16 -> int1 + # Type signature: ch:int16 -> bool # # Part of quadcode implementation ('strclass') # # Returns whether the character 'ch' is in the ASCII range. @@ -1109,11 +1110,11 @@ } ##### Function tcl.impl.isXdigit ##### # Replacement for non-exposed UniCharIsXdigit # - # Type signature: ch:int16 -> int1 + # Type signature: ch:int16 -> bool # # Part of quadcode implementation ('strclass') # # Returns whether the character 'ch' is a hex digit. @@ -1131,18 +1132,18 @@ my ret [Const false bool] } ##### Function tcl.strclass ##### # - # Type signature: objPtr:STRING * class:int32 -> ZEROONE + # Type signature: objPtr:STRING * class:int32 -> bool # # 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] + set f [$m local "tcl.strclass" bool<-STRING,int] params objPtr class build { nonnull $objPtr lassign [my GetUnicode $objPtr obj] length string my condBr [my gt $length $0] $test $match @@ -1252,11 +1253,11 @@ ##### Function tcl.impl.getIndex ##### ##### Closure Build:GetIndex ##### # # Type signature: interp:Interp* * objPtr:Tcl_Obj* * end:int - # -> int1 * int + # -> bool * 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. @@ -1343,16 +1344,16 @@ # # 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] + set f [$m local "obj.dedup" struct{STRING,bool}<-STRING] params obj build { set duped [my shared $obj] SetValueName $duped "duped" - set res [my insert [my undef struct{STRING,int1}] $duped 1] + set res [my insert [my undef struct{STRING,bool}] $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] @@ -1364,11 +1365,11 @@ 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}] + set f [$m local "obj.cleanup" void<-struct{STRING,bool}] params objdupe build { my condBr [my extract $objdupe 1] $duplicated $unshared label duplicated: my dropReference [my extract $objdupe 0] @@ -2040,10 +2041,28 @@ AddCallAttribute $call 2 nocapture my ret $new label fail: my ret [my null STRING] } + + ##### Function tcl.isList ##### + # + # Type signature: objPtr:STRING -> bool + # + # Part of quadcode implementation ('isInstance') + # + # Wrapper around Tcl_ListObjLength that uses it to do a list-ness + # check. + + set f [$m local "tcl.isList" bool<-STRING] + params objPtr + build { + nonnull $objPtr + set var [my alloc int "length"] + set code [$api Tcl_ListObjLength {} $objPtr $var] + my ret [my eq $code $0] + } ##### Function tcl.list.create ##### # # Type signature: objc:int * objv:STRING* -> STRING # @@ -2050,11 +2069,11 @@ # 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*] + set f [$m local "tcl.list.create" LIST<-int,STRING*] params objc objv build { nonnull $objv set val [$api Tcl_NewListObj $objc $objv] my addReference(STRING) $val @@ -2061,44 +2080,37 @@ my ret $val } ##### Function tcl.list.length ##### # - # Type signature: list:STRING * ecvar:int* -> INT? + # Type signature: list:LIST -> 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 + set f [$m local "tcl.list.length" INT<-LIST] + params list build { - noalias $list $ecvar - nonnull $list $ecvar + nonnull $list set var [my alloc int "length"] - set interp [$api tclInterp] - set code [$api Tcl_ListObjLength $interp $list $var] - my condBr [my eq $code $0] $ok $fail - label ok: - my ret [my ok [my packInt32 [my load $var]]] - label fail: - my store $1 $ecvar - my ret [my fail INT] + $api Tcl_ListObjLength {} $list $var + my ret [my packInt32 [my load $var]] } ##### Function tcl.list.verify ##### # - # Type signature: value:STRING * ecvar:int* -> STRING? + # Type signature: value:STRING * ecvar:int* -> LIST? # # Core of quadcode implementation ('verifyList') # # Wrapper around a list operation (Tcl_ListObjLength) that verifies # that the value it is dealing with is a list; converting it to a FAIL # if it is not. - set f [$m local "tcl.list.verify" STRING?<-STRING,int*] + set f [$m local "tcl.list.verify" LIST?<-STRING,int*] params value ecvar build { noalias $value $ecvar nonnull $value $ecvar set var [my alloc int "length"] @@ -2113,98 +2125,80 @@ my ret [my fail STRING] } ##### Function tcl.list.append ##### # - # Type signature: list:STRING * value:STRING * ecvar:int* -> STRING? + # Type signature: list:LIST * value:STRING -> LIST # # 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 + set f [$m local "tcl.list.append" LIST<-LIST,STRING] + params list value build { - noalias $ecvar - nonnull $list $value $ecvar + nonnull $list $value set interp [$api tclInterp] - my condBr [my shared $list] $sharedDupe $unshared - label sharedDupe "shared.duplicate" + my condBr [my shared $list] $shared $unshared + label shared "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 + $api Tcl_ListObjAppendElement {} $list $value + my br $return 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 ok $list] - label error: - my store $1 $ecvar - my ret [my fail STRING] + my ret $list } ##### Function tcl.list.concat ##### # - # Type signature: list:STRING * value:STRING * ecvar:int* -> STRING? + # Type signature: list:LIST * value:LIST -> LIST # # 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 + set f [$m local "tcl.list.concat" LIST<-LIST,LIST] + params list value build { - noalias $ecvar - nonnull $list $value $ecvar + nonnull $list $value set objc [my alloc int "objc"] set objv [my alloc STRING* "objv"] - set interp [$api tclInterp] - set code [$api Tcl_ListObjLength $interp $list $objc] - my condBr [my eq $code $0] $checkValue $error - label checkValue "check.value.for.listness" + $api Tcl_ListObjLength {} $list $objc 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" + $api Tcl_ListObjGetElements {} $value $objc $objv 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 working [PHI [Type LIST] {$list $copy} {$entry $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 ok $working] - label error: - my store $1 $ecvar - my ret [my fail STRING] + my ret $working } ##### Function tcl.list.index ##### # - # Type signature: list:STRING * idxc:int * idxv:STRING* * ecvar:int* + # Type signature: list:LIST * 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*] + set f [$m local "tcl.list.index" STRING?<-LIST,int,STRING*,int*] params list idxc idxv ecvar build { noalias $list $idxv $ecvar nonnull $list $idxv $ecvar set iPtr [my alloc int "&i"] @@ -2270,68 +2264,55 @@ my ret [my fail STRING] } ##### Function tcl.list.index1 ##### # - # Type signature: list:STRING * index:INT * ecvar:int* -> STRING? + # Type signature: list:LIST * index: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 + set f [$m local "tcl.list.index1" STRING<-LIST,INT] + params list index build { - noalias $list $ecvar - nonnull $list $ecvar + nonnull $list set objc [my alloc int "objc"] set objv [my alloc STRING* "objv"] - set interp [$api tclInterp] set idx [my getInt32 $index] - set code [$api Tcl_ListObjGetElements $interp $list $objc $objv] - my condBr [my eq $code $0] $ok $fail - label ok: + $api Tcl_ListObjGetElements {} $list $objc $objv 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 ok $obj] + my ret $obj label outOfBounds "out.of.bounds" set obj [$api Tcl_NewObj] my addReference(STRING) $obj - my ret [my ok $obj] - label fail: - my store $1 $ecvar - my ret [my fail STRING] + my ret $obj } ##### Function tcl.list.indexList ##### # - # Type signature: list:STRING * index:STRING * ecvar:int* -> STRING? + # Type signature: list:LIST * 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*] + set f [$m local "tcl.list.indexList" STRING?<-LIST,STRING,int*] params list index ecvar build { noalias $ecvar nonnull $list $index $ecvar set objc [my alloc int "objc"] set objv [my alloc STRING* "objv"] set interp [$api tclInterp] - 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 fail STRING] - label checkType: + $api Tcl_ListObjGetElements {} $list $objc $objv my condBr [my neq [my dereference $index 0 Tcl_Obj.typePtr] \ [$api tclListType]] \ $checkIndex $slowPath label checkIndex: set len [my load $objc] @@ -2359,32 +2340,31 @@ 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 + label notList: + # We're not a list and we know it right now + my store $1 $ecvar + my ret [my fail STRING] } ##### Function tcl.list.range ##### # - # Type signature: list:STRING * from:STRING * to:STRING -> STRING? + # Type signature: list:LIST * from:STRING * to:STRING -> LIST? # # 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*] + set f [$m local "tcl.list.range" LIST?<-LIST,STRING,STRING,int*] params list from to ecvar build { noalias $ecvar nonnull $list $from $to $ecvar set objcVar [my alloc int] set objvVar [my alloc STRING*] set interp [$api tclInterp] - set result [$api Tcl_ListObjLength $interp $list $objcVar] - my condBr [my eq $result $0] $getFrom $error - label getFrom: + $api Tcl_ListObjLength {} $list $objcVar 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 @@ -2454,30 +2434,24 @@ my ret [my fail STRING] } ##### Function tcl.list.range1 ##### # - # Type signature: list:STRING * from:INT * to:INT -> STRING? + # Type signature: list:LIST * from:INT * to:INT -> LIST # # 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 + set f [$m local "tcl.list.range1" LIST<-LIST,INT,INT] + params list from to build { - noalias $ecvar - nonnull $list $ecvar + nonnull $list set objc [my alloc int "objc"] set objv [my alloc STRING* "objv"] set interp [$api tclInterp] set from [my getInt32 $from "from"] set to [my getInt32 $to "to"] - set result [$api Tcl_ListObjGetElements $interp $list $objc $objv] - my condBr [my eq $result $0] $clamp $error - label clamp: + $api Tcl_ListObjGetElements {} $list $objc $objv 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] \ @@ -2533,26 +2507,23 @@ 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 ok $result] - label error: - my store $1 $ecvar - my ret [my fail STRING] + my ret $result } ##### Function tcl.list.set ##### # - # Type signature: list:STRING * idxc:int * idxv:STRING* * elem:STRING - # * ecvar:int* -> STRING? + # Type signature: list:LIST * idxc:int * idxv:STRING* * elem:STRING + # * ecvar:int* -> LIST? # # Core of quadcode implementation ('lset') # # Approximately equivalent to TclLsetFlat - set f [$m local "tcl.list.set" STRING?<-STRING,int,STRING*,STRING,int*] + set f [$m local "tcl.list.set" LIST?<-LIST,int,STRING*,STRING,int*] params list idxc idxv elem ecvar build { noalias $idxv $ecvar nonnull $list $idxv $elem $ecvar set subList [my alloc STRING] @@ -2694,26 +2665,23 @@ # 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*] + set f [$m local "tcl.list.set1" LIST?<-LIST,INT,STRING,int*] params list idx elem ecvar build { noalias $ecvar nonnull $list $elem $ecvar set objc [my alloc int "objc"] set objv [my alloc STRING* "objv"] set idx [my getInt32 $idx "index"] - set interp [$api tclInterp] set duped [my Dedup list] - set code [$api Tcl_ListObjGetElements $interp $list $objc $objv] - my condBr [my eq $code $1] $out $rangeCheck - label rangeCheck "range.check" + $api Tcl_ListObjGetElements {} $list $objc $objv set objc [my load $objc] my condBr [my or [my lt $idx $0] [my gt $idx $objc]] \ - $outRange $checkOperation + $error $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 @@ -2729,32 +2697,31 @@ label exit3 "exit" my addReference(STRING) $elem my br $exit2 label exit2 "exit" my ret [my ok $list] - label outRange "failure.outOfRange" + label error: + set interp [$api tclInterp] $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 fail STRING] } ##### Function tcl.list.setList ##### # - # Type signature: list:STRING * idxArg:STRING * elem:STRING - # * ecvar:int* -> STRING? + # Type signature: list:LIST * idxArg:STRING * elem:STRING + # * ecvar:int* -> LIST? # # Core of quadcode implementation ('lset') # # Approximately equivalent to TclLsetList - set f [$m local "tcl.list.setList" STRING?<-STRING,STRING,STRING,int*] + set f [$m local "tcl.list.setList" LIST?<-LIST,STRING,STRING,int*] params list idxArg elem ecvar build { noalias $ecvar nonnull $list $idxArg $elem $ecvar set ary [my alloc STRING] @@ -2779,55 +2746,48 @@ my ret $code } ##### Function tcl.list.in ##### # - # Type signature: value:STRING * list:STRING * ecVar:int* -> ZEROONE? + # Type signature: value:STRING * list:LIST * ecVar:int* -> bool? # # 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 + set f [$m local "tcl.list.in" bool<-STRING,LIST] + params value list build { - noalias $ecVar - nonnull $value $list $ecVar - set interp [$api tclInterp] - lassign [my GetString $value "string"] len1 bytes1 + nonnull $value $list 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: + lassign [my GetString $value "string"] len1 bytes1 + $api Tcl_ListObjGetElements {} $list $lenVar $objvVar set objc [my load $lenVar "objc"] set objv [my load $objvVar "objv"] - my condBr [my gt $objc $0] $loop $done + my condBr [my gt $objc $0] $loop $notFound label loop: - set i [PHI [Type int32] {$0 $iLoop} {$realCheck $loopNext} "i"] + set i [PHI [Type int32] {$0 $iLoop} {$entry $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 + $found $loopNext label loopNext: set 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 fail 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 ok $flag] + my condBr [my lt $i $objc] $loop $notFound + label notFound "not.found" + my ret [Const false bool] + label found: + my ret [Const true bool] } ##### Function tcl.list.unshare ##### # - # Type signature: list:STRING -> STRING + # Type signature: list:LIST -> LIST # # Core of quadcode implementation ('unshareList') # # Approximately equivalent to TclListObjCopy @@ -2846,20 +2806,20 @@ } ##### Function tcl.list.foreach.start.step ##### # # Type signature: - # nsteps:int?,list:STRING,stride:int->nsteps:int? + # nsteps:int? * list:LIST * stride:int -> nsteps:int? # # Core of quadcode implementation ('foreachStart') # # Works with one pair of list and assignment pattern, making sure # that the list is really a list, and updating the number of iterations # according to the given stride. set f [$m local "tcl.list.foreach.start.step" \ - int?<-int?,STRING,int] + int?<-int?,LIST,int] params steps_init list stride build { noalias $list nonnull $list set objcVar [my alloc int] @@ -2866,26 +2826,16 @@ set interp [$api tclInterp] my condBr [my maybe $steps_init] $earlierError $listLength label earlierError: my ret $steps_init label listLength: - set code [$api Tcl_ListObjLength $interp $list $objcVar] - my condBr [my eq $code $0] $lengthOk $lengthBad - label lengthOk: + $api Tcl_ListObjLength {} $list $objcVar set steps_before [my unmaybe $steps_init] set objc [my load $objcVar "objc"] set count [my div [my add $objc [my sub $stride [Const 1 int]]] \ $stride "count"] - set stepsOk [my ok [my max $steps_before $count "steps"]] - my br $done - label lengthBad: - set stepsBad [my fail int] - my br $done - label done: - set steps [my phi [list $stepsOk $stepsBad] \ - [list $lengthOk $lengthBad]] - my ret $steps + my ret [my ok [my max $steps_before $count "steps"]] } ##### Function: tcl.list.foreach.start.finish ##### # # Type signature: steps:int?,ecvar:int*->FAIL FOREACH @@ -2927,19 +2877,19 @@ my ret [my packInt32 [my extract $pair FOREACH.val]] } ##### Function tcl.list.foreach.mayStep ##### # - # Type signature: pair:FOREACH -> ZEROONE + # Type signature: pair:FOREACH -> bool # # 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] + set f [$m local "tcl.list.foreach.mayStep" bool<-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] @@ -2975,18 +2925,35 @@ # Results: # None. method DictionaryFunctions {api} { upvar 1 0 0 1 1 + + ##### Function tcl.isDict ##### + # + # Type signature: objPtr:STRING -> bool + # + # Part of quadcode implementation ('isInstance') + # + # Wrapper around Tcl_DictObjSize that uses it to do a dict-ness check. + + set f [$m local "tcl.isDict" bool<-STRING] + params objPtr + build { + nonnull $objPtr + set var [my alloc int "length"] + set code [$api Tcl_DictObjSize {} $objPtr $var] + my ret [my eq $code $0] + } ##### Function tcl.dict.exists1 ##### # - # Type signature: dict:STRING * key:STRING -> ZEROONE + # Type signature: dict:DICT * key:STRING -> bool # # Tests if a key is in a dictionary. - set f [$m local "tcl.dict.exists1" ZEROONE<-STRING,STRING] + set f [$m local "tcl.dict.exists1" bool<-DICT,STRING] params dict key build { nonnull $dict $key set resvar [my alloc STRING "valueVar"] my store [my null STRING] $resvar @@ -2996,17 +2963,15 @@ "exists"] } ##### Function tcl.dict.exists ##### # - # Type signature: dict:STRING * pathlen:int * pathobjs:STRING* - # * ecvar:int32* -> ZEROONE + # Type signature: dict:DICT * pathlen:int * pathobjs:STRING* -> bool # - # Gets a value by key from a dictionary. Can fail if the "dict" is - # not a valid dictionary. + # Tests if a key is present in a dictionary. Never fails. - set f [$m local "tcl.dict.exists" ZEROONE<-STRING,int,STRING*] + set f [$m local "tcl.dict.exists" bool<-DICT,int,STRING*] params dict keyc keyv build { noalias $dict $keyv nonnull $dict $keyv set dummy [my alloc int "dummy"] @@ -3031,48 +2996,38 @@ my ret [Const false bool] } ##### Function tcl.dict.size ##### # - # Type signature: dict:STRING * ecvar:int32* -> INT? + # Type signature: dict:DICT -> INT # - # Gets the size of a dictionary. Can fail if the "dict" is not a valid - # dictionary. + # Gets the size of a dictionary. - set f [$m local "tcl.dict.size" INT?<-STRING,int*] - params dict ecvar + set f [$m local "tcl.dict.size" INT<-DICT] + params dict build { - noalias $ecvar - nonnull $dict $ecvar + nonnull $dict set size [my alloc int "size"] - set interp [$api tclInterp] - set code [$api Tcl_DictObjSize $interp $dict $size] - my condBr [my eq $code $0] $ok $fail - label ok: - my ret [my ok [my packInt32 [my load $size]]] - label fail: - my store $1 $ecvar - my ret [my fail INT] + $api Tcl_DictObjSize {} $dict $size + my ret [my packInt32 [my load $size]] } ##### Function tcl.dict.get1 ##### # - # Type signature: dict:STRING * key:STRING * ecvar:int32* -> STRING? + # Type signature: dict:DICT * key:STRING * ecvar:int32* -> STRING? # - # Gets a value by key from a dictionary. Can fail if the "dict" is - # not a valid dictionary. + # Gets a value by key from a dictionary. Can fail if the key is + # absent. - set f [$m local "tcl.dict.get1" STRING?<-STRING,STRING,int*] + set f [$m local "tcl.dict.get1" STRING?<-DICT,STRING,int*] params dict key ecvar build { noalias $ecvar nonnull $dict $key $ecvar set resvar [my alloc STRING "valueVar"] set interp [$api tclInterp] - set result [$api Tcl_DictObjGet $interp $dict $key $resvar] - my condBr [my eq $result $0] $OK $notOK - label OK: + $api Tcl_DictObjGet {} $dict $key $resvar set value [my load $resvar "value"] my condBr [my nonnull $value] $return $fail label return: my addReference(STRING) $value my ret [my ok $value] @@ -3083,25 +3038,23 @@ "key \"%s\" not known in dictionary"] \ $keyval] $api Tcl_SetErrorCode $interp \ [my constString TCL] [my constString LOOKUP] \ [my constString DICT] $keyval {} - my br $notOK - label notOK: my store $1 $ecvar my ret [my fail STRING] } ##### Function tcl.dict.get ##### # - # Type signature: dict:STRING * pathlen:int * pathobjs:STRING* + # Type signature: dict:DICT * 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. + # Gets a value by key from a dictionary. Can fail if a "dict" inside + # the dict is not a valid dictionary. - set f [$m local "tcl.dict.get" STRING?<-STRING,int,STRING*,int*] + set f [$m local "tcl.dict.get" STRING?<-DICT,int,STRING*,int*] params dict keyc keyv ecvar build { noalias $dict $keyv $ecvar nonnull $dict $keyv $ecvar set dummy [my alloc int "dummy"] @@ -3142,67 +3095,49 @@ my ret [my fail STRING] } ##### Function tcl.dict.get1.empty ##### # - # Type signature: dict:STRING * key:STRING * ecvar:int32* -> STRING!? - # - # Gets a value by key from a dictionary. Can only fail if the "dict" - # is not a valid dictionary; an absent key in the terminal dictionary - # is reported as an NEXIST result. - - set f [$m local "tcl.dict.get1.empty" STRING!?<-STRING,STRING,int*] - params dict key ecvar + # Type signature: dict:DICT * key:STRING -> STRING! + # + # Gets a value by key from a dictionary. An absent key in the terminal + # dictionary is reported as an NEXIST result. + + set f [$m local "tcl.dict.get1.empty" STRING!<-DICT,STRING] + params dict key build { - noalias $ecvar - nonnull $dict $key $ecvar + nonnull $dict $key set resvar [my alloc STRING "valueVar"] - set interp [$api tclInterp] - set result [$api Tcl_DictObjGet $interp $dict $key $resvar] - my condBr [my eq $result $0] $OK $notOK - label OK: + $api Tcl_DictObjGet {} $dict $key $resvar set value [my load $resvar "value"] my condBr [my nonnull $value] $return $empty label return: my addReference(STRING) $value - my ret [my ok [my just $value]] + my ret [my just $value] label empty: - my ret [my ok [my nothing STRING]] - label notOK: - my store $1 $ecvar - my ret [my fail STRING!] + 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 + # Type signature: dict:DICT * key:STRING * value:STRING -> DICT + # + # Sets a key in a dictionary to map to a value. + + set f [$m local "tcl.dict.set1" DICT<-DICT,STRING,STRING] + params dict key value build { - noalias $ecvar - nonnull $dict $key $value $ecvar - set interp [$api tclInterp] + nonnull $dict $key $value set dd [my Dedup dict] - set result [$api Tcl_DictObjPut $interp $dict $key $value] - my condBr [my eq $result $0] $OK $notOK - label OK: + $api Tcl_DictObjPut {} $dict $key $value my addReference(STRING) $dict my condBr [my shared $value] $exit2 $exit3 label exit3 "exit" my addReference(STRING) $value - my br $exit2 + my ret $dict label exit2 "exit" - my ret [my ok $dict] - label notOK: - my Call obj.cleanup $dd - my store $1 $ecvar - my ret [my fail STRING] + my ret $dict } ##### Function tcl.dict.set ##### # # Type signature: dict:STRING * pathlen:int * pathobjs:STRING* @@ -3209,11 +3144,11 @@ # * 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*] + set f [$m local "tcl.dict.set" DICT?<-DICT,int,STRING*,STRING,int*] params dict pathlen pathobjs value ecvar build { noalias $pathobjs $ecvar nonnull $dict $pathobjs $value $ecvar set interp [$api tclInterp] @@ -3234,42 +3169,33 @@ my ret [my fail STRING] } ##### Function tcl.dict.unset1 ##### # - # Type signature: dict:STRING * key:STRING * ecvar:int32* -> STRING? + # Type signature: dict:DICT * key:STRING -> DICT # - # Removes a key from a dictionary. Can fail if the "dict" is not a - # valid dictionary. + # Removes a key from a dictionary. - set f [$m local "tcl.dict.unset1" STRING?<-STRING,STRING,int*] - params dict key ecvar + set f [$m local "tcl.dict.unset1" DICT<-DICT,STRING] + params dict key build { - noalias $ecvar - nonnull $dict $key $ecvar - set interp [$api tclInterp] + nonnull $dict $key set dd [my Dedup dict] - set result [$api Tcl_DictObjRemove $interp $dict $key] - my condBr [my eq $result $0] $OK $notOK - label OK: + $api Tcl_DictObjRemove {} $dict $key my addReference(STRING) $dict - my ret [my ok $dict] - label notOK: - my Call obj.cleanup $dd - my store $1 $ecvar - my ret [my fail STRING] + my ret $dict } ##### Function tcl.dict.unset ##### # - # Type signature: dict:STRING * pathlen:int * pathobjs:STRING* - # * ecvar:int32* -> STRING? + # Type signature: dict:DICT * pathlen:int * pathobjs:STRING* + # * ecvar:int32* -> DICT? # # Removes a key (or rather a key path) from a dictionary. Can fail if - # the "dict" is not a valid dictionary. + # the dictionary contains a "dict" that is not a valid dictionary. - set f [$m local "tcl.dict.unset" STRING?<-STRING,int,STRING*,int*] + set f [$m local "tcl.dict.unset" DICT?<-DICT,int,STRING*,int*] params dict pathlen pathobjs ecvar build { noalias $dict $pathobjs $ecvar nonnull $dict $pathobjs $ecvar set interp [$api tclInterp] @@ -3284,29 +3210,25 @@ my ret [my fail STRING] } ##### Function tcl.dict.set1.empty ##### # - # Type signature: dict:STRING * key:STRING * value:STRING! - # * ecvar:int32* -> STRING? + # Type signature: dict:DICT * key:STRING * value:STRING! -> DICT # # Sets a key in a dictionary to map to a value, or removes the mapping - # if the value is NEXIST. Can fail if the "dict" is not a valid - # dictionary. + # if the value is NEXIST. - set f [$m local "tcl.dict.set1.empty" \ - STRING?<-STRING,STRING,STRING!,int*] - params dict key value ecvar + set f [$m local "tcl.dict.set1.empty" DICT<-DICT,STRING,STRING!] + params dict key value build { - noalias $ecvar - nonnull $dict $key $ecvar + nonnull $dict $key my condBr [my exists $value] $reallySet $reallyUnset label reallySet "real.set" set value [my unmaybe $value] - my ret [my Call tcl.dict.set1 $dict $key $value $ecvar] + my ret [my Call tcl.dict.set1 $dict $key $value] label reallyUnset "real.unset" - my ret [my Call tcl.dict.unset1 $dict $key $ecvar] + my ret [my Call tcl.dict.unset1 $dict $key] } ##### Function tcl.dict.addIterReference ##### # # Type signature: iter:DICTITER -> void @@ -3341,43 +3263,34 @@ my ret } ##### Function tcl.dict.iterStart ##### # - # Type signature: dict:STRING * ecvar:int* -> DICTITER? + # Type signature: dict:DICT -> 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. + # iteration is stored inside the returned iteration state value. - set f [$m local "tcl.dict.iterStart" DICTITER?<-STRING,int*] - params dict ecvar + set f [$m local "tcl.dict.iterStart" DICTITER<-DICT] + params dict build { - noalias $ecvar - nonnull $dict $ecvar + nonnull $dict set done [my alloc int "done"] 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 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: + $api Tcl_DictObjFirst $interp $dict $search $key $value $done 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 ok $iter] - label failed: - $api ckfree $iter - my store $1 $ecvar - my ret [my fail DICTITER] + my ret $iter } ##### Function tcl.dict.iterNext ##### # # Type signature: iter:DICTITER -> DICTITER @@ -3497,40 +3410,35 @@ my ret $obj } ##### Function tcl.dict.iterDone ##### # - # Type signature: iter:DICTITER -> ZEROONE + # Type signature: iter:DICTITER -> bool # # Gets whether this iteration of the dictionary has finished. - set f [$m local "tcl.dict.iterDone" ZEROONE<-DICTITER] + set f [$m local "tcl.dict.iterDone" bool<-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 + # Type signature: dict:DICT * key:STRING * value:STRING -> DICT + # + # Appends to value in a dictionary indicated by a key. + + set f [$m local "tcl.dict.append" DICT<-DICT,STRING,STRING] + params dict key value + build { + nonnull $dict $key $value set valuePtr [my alloc STRING "valuePtr"] set interp [$api tclInterp] set dd [my Dedup dict] - set result [$api Tcl_DictObjGet $interp $dict $key $valuePtr] - my condBr [my eq $result $0] $OK $notOK - label OK: + $api Tcl_DictObjGet {} $dict $key $valuePtr 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 @@ -3546,38 +3454,31 @@ set c [$api Tcl_DictObjPut {} $dict $key $dictVal2] AddCallAttribute $c 3 nocapture my br $done label done: my addReference(STRING) $dict - my ret [my ok $dict] - label notOK: - my Call obj.cleanup $dd - my store $1 $ecvar - my ret [my fail STRING] + my ret $dict } ##### Function tcl.dict.incr ##### # - # Type signature: dict:STRING * key:STRING * value:INT - # * ecvar:int32* -> STRING? + # Type signature: dict:DICT * key:STRING * value:INT + # * ecvar:int32* -> DICT? # # 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. + # Can fail if the value pointed to is not a valid integer. - set f [$m local "tcl.dict.incr" STRING?<-STRING,STRING,INT,int*] + set f [$m local "tcl.dict.incr" DICT?<-DICT,STRING,INT,int*] params dict key value ecvar build { noalias $ecvar nonnull $dict $key $ecvar set valuePtr [my alloc STRING "valuePtr"] set intVar [my alloc int64 "intPtr"] set interp [$api tclInterp] set dd [my Dedup dict] - set result [$api Tcl_DictObjGet $interp $dict $key $valuePtr] - my condBr [my eq $result $0] $OK $notOK - label OK: + $api Tcl_DictObjGet {} $dict $key $valuePtr 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 @@ -3603,28 +3504,25 @@ my ret [my fail STRING] } ##### Function tcl.dict.lappend ##### # - # Type signature: dict:STRING * key:STRING * value:STRING - # * ecvar:int32* -> STRING? + # Type signature: dict:DICT * key:STRING * value:STRING + # * ecvar:int32* -> DICT? # # 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. + # value pointed to is not a valid list. - set f [$m local "tcl.dict.lappend" STRING?<-STRING,STRING,STRING,int*] + set f [$m local "tcl.dict.lappend" DICT?<-DICT,STRING,STRING,int*] params dict key value ecvar build { noalias $ecvar nonnull $dict $key $value $ecvar set valuePtr [my alloc STRING "valuePtr"] set interp [$api tclInterp] set dd [my Dedup dict] - set result [$api Tcl_DictObjGet $interp $dict $key $valuePtr] - my condBr [my eq $result $0] $OK $notOK - label OK: + $api Tcl_DictObjGet {} $dict $key $valuePtr 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] @@ -3674,17 +3572,17 @@ method StringComparisonFunctions {api} { upvar 1 sizeof sizeof 0 0 1 1 ##### Function tcl.streq ##### # - # Type signature: value1Ptr:STRING * value2Ptr:STRING -> ZEROONE + # Type signature: value1Ptr:STRING * value2Ptr:STRING -> bool # # Quadcode implementation ('streq') # # Returns whether the two string arguments are equal. - set f [$m local "tcl.streq" ZEROONE<-STRING,STRING] + set f [$m local "tcl.streq" bool<-STRING,STRING] params v1:value1Ptr v2:value2Ptr build { nonnull $v1 $v2 my condBr [my eq $v1 $v2] $identical $nexttest label nexttest: @@ -3781,18 +3679,18 @@ } ##### Function tcl.strmatch ##### # # Type signature: nocase:INT * pattern:STRING * string:STRING - # -> ZEROONE + # -> bool # # 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] + set f [$m local "tcl.strmatch" bool<-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 @@ -3813,21 +3711,21 @@ } ##### Function tcl.regexp ##### # # Type signature: flags:INT * regexp:STRING * string:STRING - # * errVar:int* -> ZEROONE? + # * errVar:int* -> bool? # # 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*] + set f [$m local "tcl.regexp" bool?<-INT,STRING,STRING,int*] params flags patternObj:regexp stringObj:string errVar:errorCode build { noalias $errVar nonnull $patternObj $stringObj $errVar set interp [$api tclInterp] @@ -3840,11 +3738,11 @@ label done "re.done" my store $0 $errVar my ret [my ok [my gt $match $0]] label err "re.error" my store $1 $errVar - my ret [my fail ZEROONE] + my ret [my fail bool] } } # Builder:@apiFunctions -- @@ -3952,11 +3850,11 @@ # 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] + set f [$module local "tcl.getreturnopts" DICT<-INT] params value:returnCode build { set code [my int.32 $value "code"] set opts [$api Tcl_GetReturnOptions [$api tclInterp] $code] SetValueName $opts "optionsObj" @@ -3964,15 +3862,15 @@ my ret $opts } ##### Function tcl.initExceptionOptions ##### # - # Type signature: objPtr:STRING * dictPtr:STRING -> int + # Type signature: objPtr:STRING * dictPtr:DICT -> int # # Initialises the return options from what we know about an exception. - set f [$module local "tcl.initExceptionOptions" int<-STRING,STRING] + set f [$module local "tcl.initExceptionOptions" int<-STRING,DICT] params result:objPtr opts:dictPtr build { nonnull $result $opts set interp [$api tclInterp] set code [$api Tcl_SetReturnOptions $interp $opts] @@ -4031,20 +3929,20 @@ } ##### Function tcl.processReturn ##### # # Type signature: result:STRING * code:int * level:int - # * returnOpts:STRING -> int + # * returnOpts:DICT -> 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] + set f [$module local "tcl.processReturn" int<-STRING,int,int,DICT] params result code level returnOpts build { nonnull $result set valuePtr [my alloc STRING "valuePtr"] set infoLen [my alloc int "infoLen"] @@ -4311,17 +4209,17 @@ my ret } ##### Function tcl.booleanTest ##### # - # Type signature: objPtr:Tcl_Obj* -> ZEROONE + # Type signature: objPtr:Tcl_Obj* -> bool # # Part of quadcode implementation ('isBoolean') # # Returns whether the string 'objPtr' is a Boolean bareword - set f [$m local "tcl.booleanTest" ZEROONE<-Tcl_Obj*] + set f [$m local "tcl.booleanTest" bool<-Tcl_Obj*] params objPtr build { nonnull $objPtr set NULL [my null Interp*] set code [my setFromAny [$api tclBooleanType] $NULL $objPtr] @@ -4453,17 +4351,17 @@ my ret [my fail STRING $code] } ##### Function tcl.existsOrError ##### # - # Type signature: exists:int1 * message:STRING * ecvar:int* -> int1 + # Type signature: exists:bool * message:STRING * ecvar:int* -> bool # # 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*] + set f [$module local "tcl.existsOrError" bool<-bool,STRING,STRING,int*] params exists message exception ecvar build { noalias $message $ecvar nonnull $message $exception $ecvar my condBr $exists $doError $done @@ -4474,17 +4372,17 @@ my ret $exists } ##### Function tcl.not.string ##### # - # Type signature: value:STRING * ecvar:int* -> ZEROONE? + # Type signature: value:STRING * ecvar:int* -> bool? # # Quadcode implementation ('not'). # # Logical negation of 'value'. - set f [$m local "tcl.not.string" ZEROONE?<-STRING,int*] + set f [$m local "tcl.not.string" bool?<-STRING,int*] params value ecvar build { noalias $ecvar nonnull $value $ecvar set bvar [my alloc int] @@ -4491,11 +4389,11 @@ set interp [$api tclInterp] set code [$api Tcl_GetBooleanFromObj $interp $value $bvar] my condBr [my eq $code [Const 0]] $ok $fail label fail: my store [Const 1] $ecvar - my ret [my fail ZEROONE] + my ret [my fail bool] label ok: my ret [my ok [my neq [my load $bvar "bool"] [Const 1]]] } my VariableHelperFunctions $api Index: codegen/struct.tcl ================================================================== --- codegen/struct.tcl +++ codegen/struct.tcl @@ -2799,10 +2799,22 @@ append body2 { [my undef STRING]} } {{EXPANDED STRING} STRING} { append body2 { $} [lindex $f 0] } + {{EXPANDED LIST} LIST} { + append body2 { $} [lindex $f 0] + } + {{EXPANDED LIST} STRING} { + append body2 { $} [lindex $f 0] + } + {{EXPANDED DICT} DICT} { + append body2 { $} [lindex $f 0] + } + {{EXPANDED DICT} STRING} { + append body2 { $} [lindex $f 0] + } {{EXPANDED INT} INT} { append body2 { $} [lindex $f 0] } {{EXPANDED DOUBLE} DOUBLE} { append body2 { $} [lindex $f 0] @@ -2811,10 +2823,88 @@ append body2 { $} [lindex $f 0] } {{EXPANDED {NUMERIC BOOLEAN}} {NUMERIC BOOLEAN}} { append body2 { $} [lindex $f 0] } + {{IMPURE DICT} STRING} { + append body2 { $} [lindex $f 0] + } + {{IMPURE EMPTY DICT} STRING} { + append body2 { $} [lindex $f 0] + } + {{IMPURE EMPTY DICT} DICT} { + append body2 { $} [lindex $f 0] + } + {{EMPTY DICT} DICT} { + append body2 { $} [lindex $f 0] + } + {DICT STRING} { + append body2 { $} [lindex $f 0] + } + {{EMPTY DICT} STRING} { + append body2 { $} [lindex $f 0] + } + {{IMPURE LIST} STRING} { + append body2 { $} [lindex $f 0] + } + {{IMPURE EMPTY LIST} STRING} { + append body2 { $} [lindex $f 0] + } + {{EMPTY LIST} STRING} { + append body2 { $} [lindex $f 0] + } + {EMPTY {EMPTY LIST}} { + append body2 { $} [lindex $f 0] + } + {EMPTY {EMPTY DICT}} { + append body2 { $} [lindex $f 0] + } + {LIST STRING} { + append body2 { $} [lindex $f 0] + } + {{IMPURE EMPTY LIST} LIST} { + append body2 { $} [lindex $f 0] + } + {{EMPTY LIST} LIST} { + append body2 { $} [lindex $f 0] + } + {DICT LIST} { + append body2 { $} [lindex $f 0] + } + {{EMPTY DICT} {EMPTY LIST}} { + append body2 { $} [lindex $f 0] + } + {{IMPURE DICT} {IMPURE LIST}} { + append body2 { $} [lindex $f 0] + } + {{IMPURE EMPTY DICT} {IMPURE EMPTY LIST}} { + append body2 { $} [lindex $f 0] + } + {{NEXIST DICT} {NEXIST STRING}} { + append body2 { $} [lindex $f 0] + } + {{NEXIST LIST} {NEXIST STRING}} { + append body2 { $} [lindex $f 0] + } + {{NEXIST EMPTY DICT} {NEXIST STRING}} { + append body2 { $} [lindex $f 0] + } + {{NEXIST EMPTY LIST} {NEXIST STRING}} { + append body2 { $} [lindex $f 0] + } + {{FAIL DICT} {FAIL STRING}} { + append body2 { $} [lindex $f 0] + } + {{FAIL LIST} {FAIL STRING}} { + append body2 { $} [lindex $f 0] + } + {{FAIL EMPTY DICT} {FAIL STRING}} { + append body2 { $} [lindex $f 0] + } + {{FAIL EMPTY LIST} {FAIL STRING}} { + append body2 { $} [lindex $f 0] + } } foreach type { BOOLEAN ZEROONE {ZEROONE BOOLEAN} @@ -2885,49 +2975,62 @@ # Side effects: # May create a method. May perform a tailcall (beware if attempting to # wrap with a filter!) method unknown {methodName args} { - if {[regexp {^addReference\(FAIL[ _]IMPURE (.*)\)$} \ - $methodName -> utype]} { - oo::objdefine [self] method $methodName {value} \ - [string map [list @utype $utype] { - set sval [my impure.string [my unmaybe $value]] - my impure.maybeAddReference [my maybe $value] $sval - }] - tailcall my $methodName {*}$args - } elseif {[regexp {^dropReference\(FAIL[ _]IMPURE[ _](.*)\)$} \ - $methodName -> utype]} { - oo::objdefine [self] method $methodName {value} \ - [string map [list @utype $utype] { - my select [my maybe $value] \ - [Const false bool] \ - [my addReference(STRING) \ - [my impure.string [my unmaybe $value]]] - }] - tailcall my $methodName {*}$args - } elseif {[regexp {^addReference\(IMPURE[ _](.*)\)$} \ - $methodName -> utype]} { - oo::objdefine [self] method $methodName {value} \ - [string map [list @utype $utype] { - my addReference(STRING) [my impure.string $value] - }] - tailcall my $methodName {*}$args - - } elseif {[regexp {^dropReference\(IMPURE[ _](.*)\)$} $methodName \ - -> utype]} { - oo::objdefine [self] method $methodName {value} \ - [string map [list @utype $utype] { - my dropReference(STRING) [my impure.string $value] - # How to determine whether the underlying type is - # itself a reference type? (Maybe never?) - #my {dropReference(@utype)} [my impure.value $value] - }] - tailcall my $methodName {*}$args - } elseif {[my MakeTypecastWrapper $methodName]} { - set v [my $methodName {*}$args] - return $v + set BASIC_REFTYPES {STRING LIST {EMPTY LIST} DICT {EMPTY DICT}} + switch -regexp -matchvar match -- $methodName { + {^addReference\(FAIL[ _]IMPURE (.*)\)$} { + lassign $match -> utype + if {$utype ni $BASIC_REFTYPES} { + oo::objdefine [self] method $methodName {value} \ + [string map [list @utype $utype] { + set sval [my impure.string [my unmaybe $value]] + my impure.maybeAddReference [my maybe $value] $sval + }] + tailcall my $methodName {*}$args + } + } + {^dropReference\(FAIL[ _]IMPURE[ _](.*)\)$} { + lassign $match -> utype + if {$utype ni $BASIC_REFTYPES} { + oo::objdefine [self] method $methodName {value} \ + [string map [list @utype $utype] { + my select [my maybe $value] \ + [Const false bool] \ + [my addReference(STRING) \ + [my impure.string [my unmaybe $value]]] + }] + tailcall my $methodName {*}$args + } + } + {^addReference\(IMPURE[ _](.*)\)$} { + lassign $match -> utype + if {$utype ni $BASIC_REFTYPES} { + oo::objdefine [self] method $methodName {value} \ + [string map [list @utype $utype] { + my addReference(STRING) [my impure.string $value] + }] + tailcall my $methodName {*}$args + } + } + {^dropReference\(IMPURE[ _](.*)\)$} { + lassign $match -> utype + if {$utype ni $BASIC_REFTYPES} { + oo::objdefine [self] method $methodName {value} \ + [string map [list @utype $utype] { + my dropReference(STRING) [my impure.string $value] + # How to determine whether the underlying type is + # itself a reference type? (Maybe never?) + #my {dropReference(@utype)} [my impure.value $value] + }] + tailcall my $methodName {*}$args + } + } + } + if {[my MakeTypecastWrapper $methodName]} { + tailcall my $methodName {*}$args } next $methodName {*}$args } unexport unknown Index: codegen/thunk.tcl ================================================================== --- codegen/thunk.tcl +++ codegen/thunk.tcl @@ -472,13 +472,18 @@ $b ret [$b extract $result 0] } $next build-in $b set result [$b unmaybe $result] } - if {[regexp "^IMPURE (.*)" $resultType]} { - set result [$b impure.string $result] - SetValueName $result @result + set resultType [string map { + {EMPTY STRING} STRING + } [string map {DICT STRING LIST STRING} $resultType]] + if {[regexp "^IMPURE (.*)" $resultType -> payload]} { + if {$payload ne "STRING"} { + set result [$b impure.string $result] + SetValueName $result @result + } set resultType STRING } upvar 0 thunk.result.$resultType thunkResultMapper if {![info exist thunkResultMapper]} { error "unhandled result type: $resultType" Index: codegen/tycon.tcl ================================================================== --- codegen/tycon.tcl +++ codegen/tycon.tcl @@ -71,11 +71,11 @@ if {[string is false -strict $value]} { return [ConstInt [Type bool] 0 0] } error "invalid boolean value \"$value\"" } - "^STRING$" - "^EMPTY$" { + "^STRING$" - "^(?:EMPTY )?(?:LIST|DICT)$" - "^EMPTY$" { variable thunkBuilder set theObj [$thunkBuilder obj.constant $value] return $theObj } {^LLVMTypeRef_\d+$} { @@ -168,11 +168,11 @@ return [IntType [expr {$::tcl_platform(wordSize) * 8}]] } {^int(\d+)$} { return [IntType [lindex $m 1]] } - ^STRING$ - ^EMPTY$ { + ^STRING$ - {^(EMPTY )?(LIST|DICT)$} - ^EMPTY$ { return [Type named{Tcl_Obj}*] } ^ZEROONE$ - ^BOOLEAN$ - "^ZEROONE BOOLEAN$" { return [Type bool] } @@ -234,10 +234,13 @@ {^(.*) FAIL$} - {^FAIL (.*)} - {^(.*)\?$} { return [Type struct{int,[Type [lindex $m 1]]}] } {^NEXIST (.*)$} - {^(.*)\!$} { return [Type struct{bool,[Type [lindex $m 1]]}] + } + {^IMPURE (?:EMPTY )?(LIST|DICT)$} { + return [Type [lindex $m 1]] } {^IMPURE (.*)$} - {^<(.*)>$} { return [Type struct{STRING,[Type [lindex $m 1]]}] } {\*$} { Index: demos/perftest/tester.tcl ================================================================== --- demos/perftest/tester.tcl +++ demos/perftest/tester.tcl @@ -2233,20 +2233,33 @@ # A simple helper that is not compiled, but rather just shortens code below proc cleanopt {script} { variable cleanopt + set badopts {-errorinfo -errorstack} + set code [uplevel 1 [list catch $script cleanopt(msg) cleanopt(opt)]] + set msg $cleanopt(msg) + set opt $cleanopt(opt) + if {[dict exists $opt -during]} { + dict set opt -during [lsort -stride 2 -dictionary -index 0 \ + [dict remove [dict get $opt -during] -during {*}$badopts]] + } + list $code $msg [lsort -stride 2 -dictionary -index 0 \ + [dict remove $opt {*}$badopts]] +} +proc cleaneropt {script} { + variable cleanopt + set badopts {-errorinfo -errorstack -errorline -errorcode} set code [uplevel 1 [list catch $script cleanopt(msg) cleanopt(opt)]] set msg $cleanopt(msg) set opt $cleanopt(opt) if {[dict exists $opt -during]} { dict set opt -during [lsort -stride 2 -dictionary -index 0 \ - [dict remove [dict get $opt -during] \ - -during -errorinfo -errorstack]] + [dict remove [dict get $opt -during] -during {*}$badopts]] } list $code $msg [lsort -stride 2 -dictionary -index 0 \ - [dict remove $opt -errorinfo -errorstack]] + [dict remove $opt {*}$badopts]] } ######################################################################### # # List of demonstration scripts. Each of these will be executed before and @@ -2489,14 +2502,14 @@ {expandtest::test3} # {expandtest::test5} Needs support for loop exception ranges {expandtest::test6 {a b c d e} {2 2} x} {expandtest::test7} {expandtest::test8} - {cleanopt {expandtest::test9}} - {cleanopt {expandtest::test10}} - {cleanopt {expandtest::test11}} - {cleanopt {expandtest::test12}} + {cleaneropt {expandtest::test9}} + {cleaneropt {expandtest::test10}} + {cleaneropt {expandtest::test11}} + {cleaneropt {expandtest::test12}} {bug-0616bcf08e::msrange 0 10} {bug-0616bcf08e::msrange2 0 10} {singleton::lforeach} {singleton::llindex} Index: quadcode/translate.tcl ================================================================== --- quadcode/translate.tcl +++ quadcode/translate.tcl @@ -206,16 +206,20 @@ my generate-arith-domain-check $pc [lindex $insn 0] $value my quads purify {temp opd0} $value set op [lindex $insn 0] my quads $op $r {temp opd0} } - listNotIn { + listIn - listNotIn { set v1 [list temp [incr depth -1]] set v0 [list temp [incr depth -1]] set r $v0 - my error-quads $pc listIn $r $v0 $v1 - my quads not $r $r + my generate-list-domain-check $pc [lindex $insn 0] $v0 + my quads purify {temp opd0} $v0 + my error-quads $pc listIn $r {temp opd0} $v1 + if {[lindex $insn 0] eq "listNotIn"} { + my quads not $r $r + } } div - expon - mod { set v1 [list temp [incr depth -1]] set v0 [list temp [incr depth -1]] set r $v0 @@ -222,11 +226,11 @@ my generate-arith-domain-check $pc [lindex $insn 0] $v0 $v1 my quads purify {temp opd0} $v0 my quads purify {temp opd1} $v1 my error-quads $pc [lindex $insn 0] $r {temp opd0} {temp opd1} } - listIn - strindex { + strindex { set v1 [list temp [incr depth -1]] set v0 [list temp [incr depth -1]] set r $v0 my error-quads $pc [lindex $insn 0] $r $v0 $v1 } @@ -242,19 +246,23 @@ set elem [list temp [incr depth -1]] set indices {} for {set i 0} {$i < [lindex $insn 1]-2} {incr i} { lappend indices [list temp [incr depth -1]] } + my generate-list-domain-check $pc [lindex $insn 0] $old + my quads purify {temp opd0} $old set new [list temp $depth] - my error-quads $pc listSet $new $old $elem {*}[lreverse $indices] + my error-quads $pc listSet $new {temp opd0} $elem {*}[lreverse $indices] } lsetList { set old [list temp [incr depth -1]] set elem [list temp [incr depth -1]] set idx [list temp [incr depth -1]] set new [list temp $depth] - my error-quads $pc listSet $new $old $elem $idx + my generate-list-domain-check $pc [lindex $insn 0] $old + my quads purify {temp opd0} $old + my error-quads $pc listSet $new {temp opd0} $elem $idx } strmatch { set flag [list literal [lindex $insn 1]] set v1 [list temp [incr depth -1]] set v0 [list temp [incr depth -1]] @@ -409,10 +417,14 @@ set lists {} foreach group $assign { lappend lists [list temp [incr n]] } set res [list temp $depth] + foreach list $lists { + my generate-list-domain-check $pc [lindex $insn 0] $list + my quads purify $list $list + } my error-quads $pc foreachStart $res [list literal $assign] {*}$lists foreach list $lists { my quads unshareList $list $list } my generate-jump [expr {$pc + 5 - $jumpOffset}] @@ -475,11 +487,13 @@ set value [list temp $depth] set key [list temp [incr depth]] set done [list temp [incr depth]] my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" - my error-quads $pc dictIterStart $var $dict + my generate-dict-domain-check $pc [lindex $insn 0] $dict + my quads purify {temp opd0} $dict + my quads dictIterStart $var {temp opd0} my quads dictIterKey $key $var my quads dictIterValue $value $var my quads dictIterDone $done $var } dictNext { @@ -496,21 +510,24 @@ } dictUpdateStart { set var [my index-to-var [lindex $insn 1]] my generate-scalar-check $pc $var {TCL READ VARNAME} \ "can't read \"%s\": variable is array" + my generate-dict-domain-check $pc [lindex $insn 0] $var + my quads purify {temp opd0} $var + set var {temp opd0} set auxNum [string range [lindex $insn 2] 1 end] set aux [lindex [dict get $bytecode auxiliary] $auxNum] - set mid [list temp opnd0] + set mid [list temp opnd1] set val [list temp [incr depth -1]] set idx 0 foreach v [dict get $aux variables] { set r [my index-to-var $v] my generate-scalar-check $pc $r {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" my error-quads $pc listIndex $mid $val [list literal $idx] - my error-quads $pc dictGetOrNexist $r $var $mid + my quads dictGetOrNexist $r $var $mid incr idx } } dictUpdateEnd { set var [my index-to-var [lindex $insn 1]] @@ -522,11 +539,12 @@ set updating [list temp opnd4] set val [list temp [incr depth -1]] set idx 0 my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't write \"%s\": variable is array" - my quads copy $updating $var + my generate-dict-domain-check $pc [lindex $insn 0] $var + my quads purify $updating $var foreach v [dict get $aux variables] { set r [my index-to-var $v] my error-quads $pc listIndex $key $val [list literal $idx] incr idx # Convert an ARRAY into a NEXIST here; ARRAY is unreadable @@ -536,11 +554,11 @@ my quads jumpFalse [list pc [expr {$n + 3}]] $isary my quads copy $mid Nothing my quads jump [list pc [expr {$n + 4}]] my quads extractScalar $mid $r # Write the value to the right key of the dict - my error-quads $pc dictSetOrUnset $updating $updating $key $mid + my quads dictSetOrUnset $updating $updating $key $mid } my quads copy $var $updating } unsetScalar { # TODO - This doesn't complain on unsetting a nonexistent @@ -561,12 +579,11 @@ dictDone { # Do nothing; general free will clean up. } verifyDict { set r [list temp [incr depth -1]] - my error-quads $pc dictSize $r $r - # The result will be discarded + my generate-dict-domain-check $pc [lindex $insn 0] $r } incrScalar1Imm { set result [list temp $depth] set var [my index-to-var [lindex $insn 1]] set delta [lindex $insn 2] @@ -703,12 +720,14 @@ } lappendListStk { set listvalue [list temp [incr depth -1]] set var [list temp [incr depth -1]] # TODO: This assumes we're dealing with qualified names! - # TODO: Typecheck: need lists in $var and $listvalue - my error-quads $pc directLappendList $var $var $listvalue + # TODO: Typecheck: need list in $var + my generate-list-domain-check $pc [lindex $insn 0] $listvalue + my quads purify {temp opd1} $listvalue + my error-quads $pc directLappendList $var $var {temp opd1} } lappendArrayStk { set value [list temp [incr depth -1]] set elem [list temp [incr depth -1]] set var [list temp [incr depth -1]] @@ -720,12 +739,14 @@ set listvalue [list temp [incr depth -1]] set elem [list temp [incr depth -1]] set var [list temp [incr depth -1]] # TODO: This assumes we're dealing with qualified names! # TODO: Typecheck: need lists in $var and $listvalue + my generate-list-domain-check $pc [lindex $insn 0] $listvalue + my quads purify {temp opd2} $listvalue my error-quads $pc \ - directArrayLappendList $var $var $elem $listvalue + directArrayLappendList $var $var $elem {temp opd2} } existStk { set var [list temp [incr depth -1]] # TODO: This assumes we're dealing with qualified names! my quads directExists $var $var @@ -780,11 +801,13 @@ # NOTE: Reversed lappend q [list temp [incr depth -1]] } set val [list temp [incr depth -1]] set r [list temp $depth] - my error-quads $pc dictGet $r $val {*}[lreverse $q] + my generate-dict-domain-check $pc [lindex $insn 0] $val + my quads purify {temp opd0} $val + my error-quads $pc dictGet $r {temp opd0} {*}[lreverse $q] } dictExists { set idxNum [lindex $insn 1] set q {} for {set i 0} {$i < $idxNum} {incr i} { @@ -791,27 +814,35 @@ # NOTE: Reversed lappend q [list temp [incr depth -1]] } set val [list temp [incr depth -1]] set r [list temp $depth] - my quads dictExists $r $val {*}[lreverse $q] + my generate-dict-domain-check $pc [lindex $insn 0] $val + my quads purify {temp opd0} $val + my quads dictExists $r {temp opd0} {*}[lreverse $q] } dictSet { set idxNum [expr [lindex $insn 1]] set var [my index-to-var [lindex $insn 2]] set val [list temp [incr depth -1]] + set vartmp {temp opd0} set q {} for {set i 0} {$i < $idxNum} {incr i} { # NOTE: Reversed lappend q [list temp [incr depth -1]] } - set r [list temp $depth] my generate-scalar-check $pc $var {TCL READ VARNAME} \ "can't read \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} - my error-quads $pc dictSet $r $var $val {*}[lreverse $q] - my quads copy $var $r + my generate-dict-domain-check $pc [lindex $insn 0] $var + my quads purify $vartmp $var + if {[llength $q] == 1} { + my quads dictSet $vartmp $vartmp $val {*}$q + } else { + my error-quads $pc dictSet $vartmp $vartmp $val {*}[lreverse $q] + } + my quads copy $var $vartmp } dictUnset { set idxNum [expr [lindex $insn 1]] set var [my index-to-var [lindex $insn 2]] set q {} @@ -821,11 +852,17 @@ } set r [list temp $depth] my generate-scalar-check $pc $var {TCL READ VARNAME} \ "can't read \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} - my error-quads $pc dictUnset $r $var {*}[lreverse $q] + my generate-dict-domain-check $pc [lindex $insn 0] $var + my quads purify {temp opd0} $var + if {[llength $q] == 1} { + my quads dictUnset $r {temp opd0} {*}$q + } else { + my error-quads $pc dictUnset $r {temp opd0} {*}[lreverse $q] + } my quads copy $var $r } dictAppend - dictLappend { set var [my index-to-var [lindex $insn 1]] set val [list temp [incr depth -1]] @@ -832,11 +869,18 @@ set key [list temp [incr depth -1]] set res [list temp $depth] my generate-scalar-check $pc $var {TCL READ VARNAME} \ "can't read \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} - my error-quads $pc [lindex $insn 0] $res $var $key $val + my generate-dict-domain-check $pc [lindex $insn 0] $var + my quads purify {temp opd0} $var + if {[lindex $insn 0] eq "dictAppend"} { + my quads [lindex $insn 0] $res {temp opd0} $key $val + } else { + # dictLappend can fail if value in dict is non-list + my error-quads $pc [lindex $insn 0] $res {temp opd0} $key $val + } my quads copy $var $res } dictIncrImm { set delta [list literal [lindex $insn 1]] set var [my index-to-var [lindex $insn 2]] @@ -843,11 +887,13 @@ set key [list temp [incr depth -1]] set res [list temp $depth] my generate-scalar-check $pc $var {TCL READ VARNAME} \ "can't read \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} - my error-quads $pc dictIncr $res $var $key $delta + my generate-dict-domain-check $pc [lindex $insn 0] $var + my quads purify {temp opd0} $var + my error-quads $pc dictIncr $res {temp opd0} $key $delta my quads copy $var $res } list { set acount [lindex $insn 1] set depth [expr {$depth - $acount}] @@ -859,35 +905,45 @@ my quads list $result {*}$qd } listIndexImm { set idx [list literal [string range [lindex $insn 1] 1 end]] set val [list temp [incr depth -1]] - my error-quads $pc listIndex $val $val $idx + my generate-list-domain-check $pc [lindex $insn 0] $val + my quads purify {temp opd0} $val + my error-quads $pc listIndex $val {temp opd0} $idx } listIndex { set idx [list temp [incr depth -1]] set val [list temp [incr depth -1]] - my error-quads $pc listIndex $val $val $idx + my generate-list-domain-check $pc [lindex $insn 0] $val + my quads purify {temp opd0} $val + my error-quads $pc listIndex $val {temp opd0} $idx } lindexMulti { set n [lindex $insn 1] set val [list temp [incr depth -$n]] for {set i 1} {$i < $n} {incr i} { + my generate-list-domain-check $pc [lindex $insn 0] $val + my quads purify $val $val my error-quads $pc listIndex $val $val [list temp [incr depth]] } # Should we do this as a single operation? c.f. TclLindexFlat } listRangeImm { set from [list literal [string range [lindex $insn 1] 1 end]] set to [list literal [string range [lindex $insn 2] 1 end]] set val [list temp [incr depth -1]] - my error-quads $pc listRange $val $val $from $to + my generate-list-domain-check $pc [lindex $insn 0] $val + my quads purify {temp opd0} $val + my error-quads $pc listRange $val {temp opd0} $from $to } listLength { set value [list temp [incr depth -1]] set r [list temp $depth] - my error-quads $pc [lindex $insn 0] $r $value + my generate-list-domain-check $pc [lindex $insn 0] $value + my quads purify {temp opd0} $value + my error-quads $pc [lindex $insn 0] $r {temp opd0} } invokeReplace { set acount [lindex $insn 1] set rcount [lindex $insn 2] set depth [expr {$depth - $acount - 1}] @@ -1208,23 +1264,27 @@ set var [my index-to-var [lindex $insn 1]] set res [list temp $depth] my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} - # TODO: Typecheck: need list in $var - my error-quads $pc listAppend $res $var $val + my generate-list-domain-check $pc [lindex $insn 0] $var + my quads purify $var $var + my quads listAppend $res $var $val my quads copy $var $res } lappendList { set listval [list temp [incr depth -1]] set var [my index-to-var [lindex $insn 1]] set res [list temp $depth] my generate-scalar-check $pc $var {TCL WRITE VARNAME} \ "can't set \"%s\": variable is array" my quads initIfNotExists $var $var {literal {}} - # TODO: Typecheck: need lists in $var and $listval - my error-quads $pc listConcat $res $var $listval + my generate-list-domain-check $pc [lindex $insn 0] $var + my quads purify $var $var + my generate-list-domain-check $pc [lindex $insn 0] $listval + my quads purify $listval $listval + my quads listConcat $res $var $listval my quads copy $var $res } lappendArray1 - lappendArray4 { set val [list temp [incr depth -1]] set idx [list temp [incr depth -1]] @@ -1234,11 +1294,13 @@ my generate-array-check $pc $ary $idx {TCL LOOKUP VARNAME} \ "can't set \"%s(%s)\": variable isn't array" my quads initArrayIfNotExists $var $var my quads arrayGet $inval $ary $idx my quads initIfNotExists $inval $inval {literal {}} - my error-quads $pc listAppend $inval $inval $val + my generate-list-domain-check $pc [lindex $insn 0] $inval + my quads purify $inval $inval + my quads listAppend $inval $inval $val my quads arraySet $ary $ary $idx $inval my quads copy $res $inval } lappendListArray { set listval [list temp [incr depth -1]] @@ -1249,21 +1311,27 @@ my generate-array-check $pc $ary $idx {TCL LOOKUP VARNAME} \ "can't set \"%s(%s)\": variable isn't array" my quads initArrayIfNotExists $ary $ary my quads arrayGet $inval $ary $idx my quads initIfNotExists $inval $inval {literal {}} - # TODO: Typecheck: need lists in $inval and $listval - my error-quads $pc listConcat $inval $inval $listval + my generate-list-domain-check $pc [lindex $insn 0] $inval + my quads purify $inval $inval + my generate-list-domain-check $pc [lindex $insn 0] $listval + my quads purify $listval $listval + my quads listConcat $inval $inval $listval my quads arraySet $ary $ary $idx $inval my quads copy $res $inval } listConcat { set list2 [list temp [incr depth -1]] set list1 [list temp [incr depth -1]] set res [list temp $depth] - # TODO: Typecheck: need lists in $list1 and $list2 - my error-quads $pc listConcat $res $list1 $list2 + my generate-list-domain-check $pc [lindex $insn 0] $list1 + my quads purify {temp opd0} $list1 + my generate-list-domain-check $pc [lindex $insn 0] $list2 + my quads purify {temp opd1} $list2 + my error-quads $pc listConcat $res {temp opd0} {temp opd1} } arrayExistsImm { set ary [my index-to-var [lindex $insn 1]] set res [list temp $depth] my quads arrayExists $res $ary @@ -1639,10 +1707,68 @@ my generate-jump $fail # 5 # The narrowing pass will insert any necessary 'extract...' instructions } + +# generate-list-domain-check / generate-dict-domain-check -- +# +# Generates a check to make sure that a value is LIST or DICT +# for the instructions that require such a value. Do not call from +# anywhere but bytecode-to-quads! +# +# Parameters: +# q - The quadruple that will consume the value +# +# Results: +# None. +# +# Side effects: +# Emits a the appropriate sequence of 'instanceOf', 'jumpTrue', +# 'initException', 'jump'. + +oo::define quadcode::transformer method generate-list-domain-check {pc inst val} { + set ok [list pc [expr {[llength $quads] + 5}]] + ; # Quadcode address to jump to on success + set fail [my exception-target $pc catch] + ; # Bytecode address to jump to on failure + + namespace upvar ::quadcode::dataType LIST typecode IMPURE impure + set impureTC [::quadcode::dataType::typeUnion $typecode $impure] + set opc [list instanceOf $impureTC {IMPURE LIST}] + + my quads $opc {temp @ok} $val + my quads jumpTrue $ok {temp @ok} + set msg [format {can't use non-list string as operand of "%s"} $inst] + set msgLit [list literal $msg] + set opts {literal {-errorcode {ARITH DOMAIN {non-numeric string}}}} + my quads initException {temp @exception} \ + $msgLit $opts {literal 1} {literal 0} + my quads extractFail {temp @exception} {temp @exception} + my generate-jump $fail +} + +oo::define quadcode::transformer method generate-dict-domain-check {pc inst val} { + set ok [list pc [expr {[llength $quads] + 5}]] + ; # Quadcode address to jump to on success + set fail [my exception-target $pc catch] + ; # Bytecode address to jump to on failure + + namespace upvar ::quadcode::dataType DICT typecode IMPURE impure + set impureTC [::quadcode::dataType::typeUnion $typecode $impure] + set opc [list instanceOf $impureTC {IMPURE DICT}] + + my quads $opc {temp @ok} $val + my quads jumpTrue $ok {temp @ok} + set msg [format {can't use non-list string as operand of "%s"} $inst] + set msgLit [list literal $msg] + set opts {literal {-errorcode {ARITH DOMAIN {non-numeric string}}}} + my quads initException {temp @exception} \ + $msgLit $opts {literal 1} {literal 0} + my quads extractFail {temp @exception} {temp @exception} + my generate-jump $fail +} # generate-arith-domain-check -- # # Generates a check to make sure that a value is NUMERIC or INT # for the instructions that require such a value. Do not call from Index: quadcode/types.tcl ================================================================== --- quadcode/types.tcl +++ quadcode/types.tcl @@ -17,11 +17,11 @@ namespace export mightbea isa allbut typeIntersect typeUnion # IMPURE - Any value that has a known internal representation may # have the IMPURE indicator to show that it has a string - # representation that must e preserved. + # representation that must be preserved. variable IMPURE [expr 0x4000000] # BOTTOM - means an inconsistency. We have contradictory information # about a given value. Should not happen. @@ -122,10 +122,30 @@ # NUMERIC_OR_BOOLEAN - the value is a number, or some spelling of # 'true' or 'false' variable NUMERIC_OR_BOOLEAN [expr {$NUMERIC | $BOOLEAN}] + + # NONEMPTYDICT - the value is a non-empty dictionary of some sort. The + # types of the keys and the values are just STRING. + + variable NONEMPTYDICT [expr 0x200] + + # NONDICTLIST - the value is a list of some sort that isn't a dictionary + # but isn't empty. The type of the elements is just STRING. + + variable NONDICTLIST [expr 0x100] + + # LIST - the value is a list of some sort. The type of the elements is + # just STRING. Note that a DICT is also a LIST. + + variable LIST [expr {$NONDICTLIST | $NONEMPTYDICT | $EMPTY}] + + # DICT - the value is a dict of some sort. The type of the keys and values + # are just STRING. Note that a DICT is also a LIST. + + variable DICT [expr {$NONEMPTYDICT | $EMPTY}] # FOREACH - the value represents the iterator of a [foreach] or [lmap]. # There are no constants of this type, and it is therefore # always pure. @@ -345,10 +365,12 @@ DICTITER DICTITER FOREACH FOREACH EXPANDED EXPANDED OTHERSTRING STRING IMPURE IMPURE + NONDICTLIST LIST + NONEMPTYDICT DICT EMPTY EMPTY } { namespace upvar dataType $name t if {$type & $t} { namespace upvar dataType $wname w @@ -497,11 +519,11 @@ DOUBLE DOUBLE INT INT STRING STRING FAIL FAIL EMPTY EMPTY ZEROONE ZEROONE BOOL_INT BOOL BOOLWORD BOOLWORD ENTIER ENTIER NUMERIC NUMERIC IMPURE IMPURE VOID VOID CALLFRAME CALLFRAME DICTITER DICTITER FOREACH FOREACH - ARRAY ARRAY NEXIST NEXIST EXPANDED EXPANDED + ARRAY ARRAY NEXIST NEXIST EXPANDED EXPANDED LIST LIST DICT DICT } switch -exact -- [lindex $q 0 0] { debug-value { return [typeOfOperand $types [lindex $q 3]] @@ -627,10 +649,11 @@ gt - instanceOf - isBoolean - land - le - + listIn - lor - lt - neq - strclass - streq - @@ -645,15 +668,15 @@ } else { puts "which might FAIL" return [expr {$ZEROONE | $FAIL}] } } - regexp - listIn { + regexp { return [expr {$ZEROONE | $FAIL}] } listLength - dictSize { - return [expr {$INT | $FAIL}] + return $INT } phi { set r 0 foreach {from operand} [lrange $q 2 end] { set r [expr {$r | [typeOfOperand $types $operand]}] @@ -680,11 +703,11 @@ return $t1 } return [expr {$EXPANDED | $t1}] } verifyList { - return [expr {$FAIL | [typeOfOperand $types [lindex $q 2]]}] + return [expr {$FAIL | $LIST}] } invoke { # We know the result type of a handful of the things # that might be invoked if {[lindex $q 3 0] eq "literal"} { @@ -713,41 +736,88 @@ } extractCallFrame { # Trim the non-callframe part return $CALLFRAME } - list - unshareList - - result - returnOptions - - dictIterKey - dictIterValue - + list - unshareList { + return $LIST + } + returnOptions { + return $DICT + } + result - dictIterKey - dictIterValue - concat - strcat - strmap - strtrim - strcase { return $STRING } foreachAdvance { return $FOREACH } foreachStart { return [expr {$FOREACH | $FAIL}] } - strindex - strrange - strreplace - - listAppend - listConcat - listIndex - listSet - - dictSet - dictSetOrUnset - dictGet - listRange - dictUnset - - dictAppend - dictIncr - dictLappend { + listAppend - listConcat { + return $LIST + } + listIndex { + if {[llength $q] == 4} { + set t2 [typeOfOperand $types [lindex $q 3]] + # TODO: have end-relative indices be their own type + if {istype($t2, $INT) || istype($t2, $ZEROONE)} { + return $STRING + } + } elseif {[llength $q] == 3} { + return [typeOfOperand $types [lindex $q 2]] + } + return [expr {$STRING | $FAIL}] + } + listRange { + set t1 [typeOfOperand $types [lindex $q 3]] + set t2 [typeOfOperand $types [lindex $q 4]] + # TODO: have end-relative indices be their own type + if {(istype($t1, $INT) || istype($t1, $ZEROONE)) && + (istype($t2, $INT) || istype($t2, $ZEROONE))} { + return $LIST + } + return [expr {$LIST | $FAIL}] + } + listSet { + return [expr {$LIST | $FAIL}] + } + strindex - strrange - strreplace - dictGet { + # TODO: have end-relative indices be their own type and be non-failing return [expr {$STRING | $FAIL}] } + dictSetOrUnset - dictAppend { + return $DICT + } + dictUnset { + if {[llength $q] == 4} { + return $DICT + } else { + return [expr {$DICT | $FAIL}] + } + } + dictSet { + if {[llength $q] == 5} { + return $DICT + } else { + return [expr {$DICT | $FAIL}] + } + } + dictIncr - dictLappend { + return [expr {$DICT | $FAIL}] + } dictGetOrNexist { - return [expr {$STRING | $FAIL | $NEXIST}] + return [expr {$STRING | $NEXIST}] } arrayGet { return [expr {$STRING | $NEXIST}] } arraySet - arrayUnset - initArray { return $ARRAY } - dictIterStart { - return [expr {$DICTITER | $FAIL}] - } - dictIterNext { + dictIterStart - dictIterNext { return $DICTITER } initIfNotExists { set vartype [typeOfOperand $types [lindex $q 2]] set deftype [typeOfOperand $types [lindex $q 3]] @@ -898,10 +968,27 @@ } else { return [dataType::typeUnion $dataType::DOUBLE $dataType::IMPURE] } } elseif {[string is boolean -strict $x]} { return [dataType::typeUnion $dataType::BOOLEAN $dataType::IMPURE] + } elseif {[string is list $x] && ($x eq [list {*}$x])} { + # Purity is determined by seeing if the string value could be made by + # [list]; if not, we've got a value with extra whitespace we should + # preserve. + + # We claim that lists of length one are simple STRINGs; that's usually + # a more honest choice. + if {[llength $x] <= 1} { + return $dataType::IMPUREOTHERSTRING + } + # Odd-length LISTs cannot be DICTs, and we prefer to not call them + # DICTs if they have non-unique keys. + if {([llength $x] & 1) == 0 && [dict create {*}$x] eq $x} { + return $dataType::NONEMPTYDICT + } else { + return $dataType::NONDICTLIST + } } else { return $dataType::IMPUREOTHERSTRING } }