Check-in [721be90d96]
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Expansion... sort of
Timelines: family | ancestors | list-and-dict-types
Files: files | file ages | folders
SHA3-256: 721be90d969652e5a76c9ad38fe221ebcd67020bd6744bfcf52ecfa4781d10e8
User & Date: dkf 2019-02-02 18:14:46
Context
2019-02-02
18:14
Expansion... sort of Leaf check-in: 721be90d96 user: dkf tags: list-and-dict-types
2019-01-02
16:22
A little bit less wrong. check-in: 75fd3b203e user: dkf tags: list-and-dict-types
Changes

Changes to codegen/compile.tcl.

   562    562   		    set src1 [lindex $srcs 0]
   563    563   		    set name [my LocalVarName $tgt]
   564    564   		    append opcode ( [my ValueTypes {*}$srcs] )
   565    565   		    set srcs [lmap s $srcs {my LoadOrLiteral $s}]
   566    566   		    set canFail [expr {"FAIL" in operandType($tgt)}]
   567    567   		    set ec [if {$canFail} {list $errorCode}]
   568    568   		    if {consumed($src1, $pc + 1)} {
   569         -			$b printref $value "[lindex $l 0 0]:A:"
          569  +			$b printref [lindex $srcs 0] "[lindex $l 0 0]:A:"
   570    570   			set res [$b $opcode {*}$srcs {*}$ec $name]
   571    571   		    } else {
   572         -			$b printref $value "[lindex $l 0 0]:B:"
          572  +			$b printref [lindex $srcs 0] "[lindex $l 0 0]:B:"
   573    573   			$b addReference([my OperandType $src1]) [lindex $srcs 0]
   574    574   			set res [$b $opcode {*}$srcs {*}$ec $name]
   575    575   			$b dropReference([my OperandType $src1]) [lindex $srcs 0]
   576    576   		    }
   577    577   		    if {$canFail} {
   578    578   			my SetErrorLine $errorCode [$b maybe $res]
   579    579   		    }
................................................................................
   610    610   		    set srcs [lassign $l opcode tgt srcObj]
   611    611   		    set name [my LocalVarName $tgt]
   612    612   		    if {[llength $srcs] == 1} {
   613    613   			# Simple case
   614    614   			set srcs [list $srcObj {*}$srcs]
   615    615   			append opcode ( [my ValueTypes {*}$srcs] )
   616    616   			set srcs [lmap s $srcs {my LoadOrLiteral $s}]
   617         -			set res [$b $opcode {*}$srcs $errorCode $name]
          617  +			set res [$b $opcode {*}$srcs $name]
   618    618   			my StoreResult $tgt $res
   619    619   		    } else {
   620    620   			# Need to construct the variadic path
   621    621   			set vectortypes [lmap s $srcs {my OperandType $s}]
   622    622   			set vector [$b buildVector $objv $vectortypes \
   623    623   				  [lmap s $srcs {my LoadOrLiteral $s}]]
   624    624   			append opcode ( [my OperandType $srcObj] )
................................................................................
  1461   1461   	    return [$b frame.pack $frame $value $name]
  1462   1462   	} elseif {"CALLFRAME" in $tgttype} {
  1463   1463   	    error "callframe injection"
  1464   1464   	}
  1465   1465   
  1466   1466   	# Handle FAIL-extended types
  1467   1467   	if {"FAIL" eq $srctype && "FAIL" in $tgttype} {
         1468  +	    my Warn "widen FAIL (%s) to %s" [PrintValueToString $value] $tgttype
  1468   1469   	    # Implementation type of pure FAIL is int32 (Tcl result code)
  1469   1470   	    set tgttype [lrange $tgttype 1 end]
  1470   1471   	    return [$b fail $tgttype $value]
  1471   1472   	} elseif {"FAIL" in $srctype && "FAIL" in $tgttype} {
  1472   1473   	    set value [$b unmaybe $value]
  1473   1474   	    set srctype [lrange $srctype 1 end]
  1474   1475   	    set tgttype [lrange $tgttype 1 end]

Changes to codegen/stdlib.tcl.

   176    176   	#
   177    177   	# Increment the reference count of a Tcl_Obj reference if the
   178    178   	# object is supplied
   179    179   
   180    180   	set f [$m local "tcl.addFailReference" void<-Tcl_Obj*?]
   181    181   	params value:maybeObjPtr
   182    182   	build {
   183         -	    my condBr [my maybe $value] $nothing $incr
          183  +	    my condBr [my maybe $value] $incr $nothing
   184    184   	label incr "action.required.afr"
   185    185   	    set value [my unmaybe $value "objPtr"]
   186    186   	    $api Tcl_IncrRefCount $value
   187    187   	    my ret
   188    188   	label nothing "nothing.to.do"
   189    189   	    my ret
   190    190   	}
................................................................................
   195    195   	#
   196    196   	# Decrement the reference count of a Maybe containing a Tcl_Obj
   197    197   	# reference, and delete it if the reference count drops to zero.
   198    198   
   199    199   	set f [$m local "tcl.dropFailReference" void<-Tcl_Obj*?]
   200    200   	params value:maybeObjPtr
   201    201   	build {
   202         -	    my condBr [my maybe $value] $nothing $decr
          202  +	    my condBr [my maybe $value] $decr $nothing
   203    203   	label decr "action.required"
   204    204   	    set value [my unmaybe $value "objPtr"]
   205    205   	    $api Tcl_DecrRefCount $value
   206    206   	    my ret
   207    207   	label nothing "nothing.to.do"
   208    208   	    my ret
   209    209   	}
................................................................................
   294    294   	#
   295    295   	# Decrement the reference count of a Maybe Maybe containing a Tcl_Obj
   296    296   	# reference, and delete it if the reference count drops to zero.
   297    297   
   298    298   	set f [$m local "tcl.dropFailNExistReference" void<-Tcl_Obj*!?]
   299    299   	params value:maybeObjPtr
   300    300   	build {
   301         -	    my condBr [my maybe $value] $nothing $decr
          301  +	    my condBr [my maybe $value] $decr $nothing
   302    302   	label decr "action.required"
   303    303   	    my Call tcl.dropNExistReference [my unmaybe $value]
   304    304   	    my ret
   305    305   	label nothing "nothing.to.do"
   306    306   	    my ret
   307    307   	}
   308    308   
................................................................................
   500    500   	params pr val prefix
   501    501   	build {
   502    502   	    my condBr [my maybe $val] $done $print
   503    503   	label print:
   504    504   	    my Call writeref $pr [my unmaybe $val] $prefix
   505    505   	    my ret
   506    506   	label done:
          507  +	    my Call writeref $pr {} $prefix
   507    508   	    my ret
   508    509   	}
   509    510   	set f [$m local writearef void<-int,ARRAY,char* noinline]
   510    511   	params pr val prefix
   511    512   	build {
   512    513   	    nonnull $val
   513    514   	    set chan [$api Tcl_GetStdChannel [Const [expr 1<<3]]]

Changes to codegen/struct.tcl.

  2797   2797   	    }
  2798   2798   	    {NOTHING STRING} {
  2799   2799   		append body2 { [my undef STRING]}
  2800   2800   	    }
  2801   2801   	    {{EXPANDED STRING} STRING} {
  2802   2802   		append body2 { $} [lindex $f 0]
  2803   2803   	    }
         2804  +	    {{EXPANDED LIST} LIST} {
         2805  +		append body2 { $} [lindex $f 0]
         2806  +	    }
         2807  +	    {{EXPANDED LIST} STRING} {
         2808  +		append body2 { $} [lindex $f 0]
         2809  +	    }
         2810  +	    {{EXPANDED DICT} DICT} {
         2811  +		append body2 { $} [lindex $f 0]
         2812  +	    }
         2813  +	    {{EXPANDED DICT} STRING} {
         2814  +		append body2 { $} [lindex $f 0]
         2815  +	    }
  2804   2816   	    {{EXPANDED INT} INT} {
  2805   2817   		append body2 { $} [lindex $f 0]
  2806   2818   	    }
  2807   2819   	    {{EXPANDED DOUBLE} DOUBLE} {
  2808   2820   		append body2 { $} [lindex $f 0]
  2809   2821   	    }
  2810   2822   	    {{EXPANDED NUMERIC} NUMERIC} {

Changes to quadcode/types.tcl.

   701    701   	    # Simple numbers are simple words when not IMPURE
   702    702   	    if {istype($t1,$NUMERIC) && !($t1 & $IMPURE)} {
   703    703   		return $t1
   704    704   	    }
   705    705   	    return [expr {$EXPANDED | $t1}]
   706    706   	}
   707    707   	verifyList {
   708         -	    return [expr {$FAIL | [typeOfOperand $types [lindex $q 2]]}]
          708  +	    return [expr {$FAIL | $LIST}]
   709    709   	}
   710    710   	invoke {
   711    711   	    # We know the result type of a handful of the things
   712    712   	    # that might be invoked
   713    713   	    if {[lindex $q 3 0] eq "literal"} {
   714    714   		set rtype [my typeOfInvoke [lindex $q 3 1] [lrange $q 4 end]]
   715    715   	    } else {
................................................................................
   756    756   	}
   757    757   	listAppend - listConcat {
   758    758   	    return $LIST
   759    759   	}
   760    760   	listIndex {
   761    761   	    if {[llength $q] == 4} {
   762    762   		set t2 [typeOfOperand $types [lindex $q 3]]
          763  +		# TODO: have end-relative indices be their own type
   763    764   		if {istype($t2, $INT) || istype($t2, $ZEROONE)} {
   764    765   		    return $STRING
   765    766   		}
   766    767   	    } elseif {[llength $q] == 3} {
   767    768   		return [typeOfOperand $types [lindex $q 2]]
   768    769   	    }
   769    770   	    return [expr {$STRING | $FAIL}]
   770    771   	}
   771    772   	listRange {
   772    773   	    set t1 [typeOfOperand $types [lindex $q 3]]
   773         -	    set t2 [typeOfOperand $types [lindex $q 3]]
          774  +	    set t2 [typeOfOperand $types [lindex $q 4]]
          775  +	    # TODO: have end-relative indices be their own type
   774    776   	    if {(istype($t1, $INT) || istype($t1, $ZEROONE)) &&
   775    777   		    (istype($t2, $INT) || istype($t2, $ZEROONE))} {
   776    778   		return $LIST
   777    779   	    }
   778    780   	    return [expr {$LIST | $FAIL}]
   779    781   	}
   780    782   	listSet {
   781    783   	    return [expr {$LIST | $FAIL}]
   782    784   	}
   783    785   	strindex - strrange - strreplace - dictGet {
          786  +	    # TODO: have end-relative indices be their own type and be non-failing
   784    787   	    return [expr {$STRING | $FAIL}]
   785    788   	}
   786    789   	dictSetOrUnset - dictAppend {
   787    790   	    return $DICT
   788    791   	}
   789    792   	dictUnset {
   790    793   	    if {[llength $q] == 4} {