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 tclconference@googlegroups.com
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
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
...
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
....
1461
1462
1463
1464
1465
1466
1467

1468
1469
1470
1471
1472
1473
1474
		    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)} {
			$b printref $value "[lindex $l 0 0]:A:"
			set res [$b $opcode {*}$srcs {*}$ec $name]
		    } else {
			$b printref $value "[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 {$canFail} {
			my SetErrorLine $errorCode [$b maybe $res]
		    }
................................................................................
		    set srcs [lassign $l opcode tgt srcObj]
		    set name [my LocalVarName $tgt]
		    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]
			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}]]
			append opcode ( [my OperandType $srcObj] )
................................................................................
	    return [$b frame.pack $frame $value $name]
	} elseif {"CALLFRAME" in $tgttype} {
	    error "callframe injection"
	}

	# Handle FAIL-extended types
	if {"FAIL" eq $srctype && "FAIL" in $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]
	    set srctype [lrange $srctype 1 end]
	    set tgttype [lrange $tgttype 1 end]







|


|







 







|







 







>







562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
...
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
....
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
		    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)} {
			$b printref [lindex $srcs 0] "[lindex $l 0 0]:A:"
			set res [$b $opcode {*}$srcs {*}$ec $name]
		    } else {
			$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 {$canFail} {
			my SetErrorLine $errorCode [$b maybe $res]
		    }
................................................................................
		    set srcs [lassign $l opcode tgt srcObj]
		    set name [my LocalVarName $tgt]
		    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 $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}]]
			append opcode ( [my OperandType $srcObj] )
................................................................................
	    return [$b frame.pack $frame $value $name]
	} elseif {"CALLFRAME" in $tgttype} {
	    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]
	    set srctype [lrange $srctype 1 end]
	    set tgttype [lrange $tgttype 1 end]

Changes to codegen/stdlib.tcl.

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
...
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
...
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
...
500
501
502
503
504
505
506

507
508
509
510
511
512
513
	#
	# Increment the reference count of a Tcl_Obj reference if the
	# 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.afr"
	    set value [my unmaybe $value "objPtr"]
	    $api Tcl_IncrRefCount $value
	    my ret
	label nothing "nothing.to.do"
	    my ret
	}
................................................................................
	#
	# Decrement the reference count of a Maybe containing a Tcl_Obj
	# reference, and delete it if the reference count drops to zero.

	set f [$m local "tcl.dropFailReference" void<-Tcl_Obj*?]
	params value:maybeObjPtr
	build {
	    my condBr [my maybe $value] $nothing $decr
	label decr "action.required"
	    set value [my unmaybe $value "objPtr"]
	    $api Tcl_DecrRefCount $value
	    my ret
	label nothing "nothing.to.do"
	    my ret
	}
................................................................................
	#
	# Decrement the reference count of a Maybe Maybe containing a Tcl_Obj
	# 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
	label decr "action.required"
	    my Call tcl.dropNExistReference [my unmaybe $value]
	    my ret
	label nothing "nothing.to.do"
	    my ret
	}

................................................................................
	params pr val prefix
	build {
	    my condBr [my maybe $val] $done $print
	label print:
	    my Call writeref $pr [my unmaybe $val] $prefix
	    my ret
	label done:

	    my ret
	}
	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]]]







|







 







|







 







|







 







>







176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
...
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
...
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
...
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
	#
	# Increment the reference count of a Tcl_Obj reference if the
	# object is supplied

	set f [$m local "tcl.addFailReference" void<-Tcl_Obj*?]
	params value:maybeObjPtr
	build {
	    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
	}
................................................................................
	#
	# Decrement the reference count of a Maybe containing a Tcl_Obj
	# reference, and delete it if the reference count drops to zero.

	set f [$m local "tcl.dropFailReference" void<-Tcl_Obj*?]
	params value:maybeObjPtr
	build {
	    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"
	    my ret
	}
................................................................................
	#
	# Decrement the reference count of a Maybe Maybe containing a Tcl_Obj
	# 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] $decr $nothing
	label decr "action.required"
	    my Call tcl.dropNExistReference [my unmaybe $value]
	    my ret
	label nothing "nothing.to.do"
	    my ret
	}

................................................................................
	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* noinline]
	params pr val prefix
	build {
	    nonnull $val
	    set chan [$api Tcl_GetStdChannel [Const [expr 1<<3]]]

Changes to codegen/struct.tcl.

2797
2798
2799
2800
2801
2802
2803












2804
2805
2806
2807
2808
2809
2810
	    }
	    {NOTHING STRING} {
		append body2 { [my undef STRING]}
	    }
	    {{EXPANDED STRING} STRING} {
		append body2 { $} [lindex $f 0]
	    }












	    {{EXPANDED INT} INT} {
		append body2 { $} [lindex $f 0]
	    }
	    {{EXPANDED DOUBLE} DOUBLE} {
		append body2 { $} [lindex $f 0]
	    }
	    {{EXPANDED NUMERIC} NUMERIC} {







>
>
>
>
>
>
>
>
>
>
>
>







2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
	    }
	    {NOTHING STRING} {
		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]
	    }
	    {{EXPANDED NUMERIC} NUMERIC} {

Changes to quadcode/types.tcl.

701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
...
756
757
758
759
760
761
762

763
764
765
766
767
768
769
770
771
772
773

774
775
776
777
778
779
780
781
782
783

784
785
786
787
788
789
790
	    # Simple numbers are simple words when not IMPURE
	    if {istype($t1,$NUMERIC) && !($t1 & $IMPURE)} {
		return $t1
	    }
	    return [expr {$EXPANDED | $t1}]
	}
	verifyList {
	    return [expr {$FAIL | [typeOfOperand $types [lindex $q 2]]}]
	}
	invoke {
	    # We know the result type of a handful of the things
	    # that might be invoked
	    if {[lindex $q 3 0] eq "literal"} {
		set rtype [my typeOfInvoke [lindex $q 3 1] [lrange $q 4 end]]
	    } else {
................................................................................
	}
	listAppend - listConcat {
	    return $LIST
	}
	listIndex {
	    if {[llength $q] == 4} {
		set t2 [typeOfOperand $types [lindex $q 3]]

		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 3]]

	    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 {

	    return [expr {$STRING | $FAIL}]
	}
	dictSetOrUnset - dictAppend {
	    return $DICT
	}
	dictUnset {
	    if {[llength $q] == 4} {







|







 







>










|
>










>







701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
...
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
	    # Simple numbers are simple words when not IMPURE
	    if {istype($t1,$NUMERIC) && !($t1 & $IMPURE)} {
		return $t1
	    }
	    return [expr {$EXPANDED | $t1}]
	}
	verifyList {
	    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"} {
		set rtype [my typeOfInvoke [lindex $q 3 1] [lrange $q 4 end]]
	    } else {
................................................................................
	}
	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} {