From dee25b4393e2e10d9ac8251d31889efa6378c9ed Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Mon, 18 Mar 2024 23:29:52 +1100 Subject: [PATCH] move lpop,lremove from punk, to punk::lib::compat --- src/modules/punk-0.1.tm | 146 ---------------------- src/modules/punk/lib-999999.0a1.0.tm | 173 +++++++++++++++++++++++++++ 2 files changed, 173 insertions(+), 146 deletions(-) diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index c4fb6b4..fc46227 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -145,153 +145,7 @@ namespace eval punk { debug header "dbg> " - if {"::lremove" ne [info commands ::lremove]} { - puts stderr "Warning - no built-in lremove" - proc ::lremove {list args} { - set data [lmap v $list {list data $v}] - foreach doomed_index $args { - if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} - lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value - } - set keep [lsearch -all -inline -not -exact $data x] - return [lsearch -all -inline -index 1 -subindices $keep *] - } - #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers - proc ::lremove2 {list args} { - set data [lmap v $list {list data $v}] - foreach doomed_index $args { - if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} - lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value - } - set keep [lsearch -all -inline -not -exact $data x] - return [lmap v $keep {lindex $v 1}] - } - #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. - #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 - and even in 8.7 it doesn't seem to allow returning one index of the stridden 'group' - } - if {"::lpop" ne [info commands ::lpop]} { - puts stderr "Warning - no built-in lpop" - interp alias {} lpop {} ::punk::lpop - } - proc lpop {lvar args} { - upvar $lvar l - if {![llength $args]} { - set args [list end] - } - set v [lindex $l {*}$args] - set newlist $l - - set path [list] - set subl $l - for {set i 0} {$i < [llength $args]} {incr i} { - set idx [lindex $args $i] - if {![llength [lrange $subl $idx $idx]]} { - error "tcl_lpop index \"$idx\" out of range" - } - #if {[list_index_get $subl $idx] == -1} { - # error "tcl_lpop index \"$idx\" out of range" - #} - lappend path [lindex $args $i] - set subl [lindex $l {*}$path] - } - set sublist_path [lrange $args 0 end-1] - set tailidx [lindex $args end] - if {![llength $sublist_path]} { - #set newlist [lremove $newlist $tailidx] - set newlist [lreplace $newlist $tailidx $tailidx] - } else { - set sublist [lindex $newlist {*}$sublist_path] - #set sublist [lremove $sublist $tailidx] - set sublist [lreplace $sublist $tailidx $tailidx] - lset newlist {*}$sublist_path $sublist - } - #puts "[set l] -> $newlist" - set l $newlist - return $v - } - proc list_index_resolve {list index} { - #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr - if {![llength $list]} { - return -1 - } - set index [string map [list _ ""] $index] ;#forward compatibility with integers such as 1_000 - if {[string is integer -strict $index]} { - #can match +i -i - if {$index < 0} { - return -1 - } elseif {$index >= [llength $list]} { - return -1 - } else { - #integer may still have + sign - normalize with expr - return [expr {$index}] - } - } else { - if {[string match end* $index]} { - if {$index ne "end"} { - set op [string index $index 3] - set offset [string range $index 4 end] - if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} - if {$op eq "+" && $offset != 0} { - return -1 - } - } else { - set offset 0 - } - #by now, if op = + then offset = 0 so we only need to handle the minus case - if {$offset == 0} { - set index [expr {[llength $list]-1}] - } else { - set index [expr {([llength $list]-1) - $offset}] - } - if {$index < 0} { - return -1 - } else { - return $index - } - } else { - #plain +- already handled above. - #we are trying to avoid evaluating unbraced expr of potentially insecure origin - if {[regexp {(.*)([+-])(.*)} $index _match a op b]} { - if {[string is integer -strict $a] && [string is integer -strict $b]} { - if {$op eq "-"} { - set index [expr {$a - $b}] - } else { - set index [expr {$a + $b}] - } - } else { - error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" - } - } else { - error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" - } - if {$index < 0 || $index >= [llength $list]} {return -1} - return $index - } - } - } - proc list_index_resolve2 {list index} { - set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. - for {set i 0} {$i < [llength $list]} {incr i} { - lappend indices $i - } - set idx [lindex $indices $index] - if {$idx eq ""} { - return -1 - } else { - return $idx - } - } - proc list_index_get {list index} { - set resultlist [lrange $list $index $index] - if {![llength $resultlist]} { - return -1 - } else { - #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. - #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator - return [dict create value [lindex $resultlist 0]] - } - } variable last_run_display [list] diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 548666f..531210d 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -96,6 +96,94 @@ namespace eval punk::lib::class { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::lib::compat { + #*** !doctools + #[subsection {Namespace punk::lib::compat}] + #[para] compatibility functions for features that may not be available in earlier Tcl versions + #[para] These are generally 'forward compatibility' functions ie allowing earlier versions to use later features/idioms by using a Tcl-only version of a missing builtin. + #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. + + #*** !doctools + #[list_begin enumerated] + + if {"::lremove" ne [info commands ::lremove]} { + #puts stderr "Warning - no built-in lremove" + interp alias {} lremove {} ::punk::lib::compat::lremove + } + proc lremove {list args} { + #*** !doctools + #[call [fun lremove] [arg list] [opt {index ...}]] + #[para] Forwards compatible lremove for versions 8.6 or less to support equivalent 8.7 lremove + + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lsearch -all -inline -index 1 -subindices $keep *] + } + #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers + proc lremove2 {list args} { + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lmap v $keep {lindex $v 1}] + } + #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 - and even in 8.7 it doesn't seem to allow returning one index of the stridden 'group' + + if {"::lpop" ne [info commands ::lpop]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lpop {} ::punk::lib::compat::lpop + } + proc lpop {lvar args} { + #*** !doctools + #[call [fun lpop] [arg listvar] [opt {index}]] + #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop + upvar $lvar l + if {![llength $args]} { + set args [list end] + } + set v [lindex $l {*}$args] + set newlist $l + + set path [list] + set subl $l + for {set i 0} {$i < [llength $args]} {incr i} { + set idx [lindex $args $i] + if {![llength [lrange $subl $idx $idx]]} { + error "tcl_lpop index \"$idx\" out of range" + } + lappend path [lindex $args $i] + set subl [lindex $l {*}$path] + } + + set sublist_path [lrange $args 0 end-1] + set tailidx [lindex $args end] + if {![llength $sublist_path]} { + #set newlist [lremove $newlist $tailidx] + set newlist [lreplace $newlist $tailidx $tailidx] + } else { + set sublist [lindex $newlist {*}$sublist_path] + #set sublist [lremove $sublist $tailidx] + set sublist [lreplace $sublist $tailidx $tailidx] + lset newlist {*}$sublist_path $sublist + } + #puts "[set l] -> $newlist" + set l $newlist + return $v + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -122,6 +210,91 @@ namespace eval punk::lib { # return "ok" #} + + proc list_index_resolve {list index} { + #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr + if {![llength $list]} { + return -1 + } + set index [string map [list _ ""] $index] ;#forward compatibility with integers such as 1_000 + if {[string is integer -strict $index]} { + #can match +i -i + if {$index < 0} { + return -1 + } elseif {$index >= [llength $list]} { + return -1 + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } else { + if {[string match end* $index]} { + if {$index ne "end"} { + set op [string index $index 3] + set offset [string range $index 4 end] + if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} + if {$op eq "+" && $offset != 0} { + return -1 + } + } else { + set offset 0 + } + #by now, if op = + then offset = 0 so we only need to handle the minus case + if {$offset == 0} { + set index [expr {[llength $list]-1}] + } else { + set index [expr {([llength $list]-1) - $offset}] + } + if {$index < 0} { + return -1 + } else { + return $index + } + } else { + #plain +- already handled above. + #we are trying to avoid evaluating unbraced expr of potentially insecure origin + if {[regexp {(.*)([+-])(.*)} $index _match a op b]} { + if {[string is integer -strict $a] && [string is integer -strict $b]} { + if {$op eq "-"} { + set index [expr {$a - $b}] + } else { + set index [expr {$a + $b}] + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + if {$index < 0 || $index >= [llength $list]} {return -1} + return $index + } + } + } + proc list_index_resolve2 {list index} { + set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. + for {set i 0} {$i < [llength $list]} {incr i} { + lappend indices $i + } + set idx [lindex $indices $index] + if {$idx eq ""} { + return -1 + } else { + return $idx + } + } + proc list_index_get {list index} { + set resultlist [lrange $list $index $index] + if {![llength $resultlist]} { + return -1 + } else { + #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. + #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator + return [dict create value [lindex $resultlist 0]] + } + } + + proc K {x y} {return $x} #*** !doctools #[call [fun K] [arg x] [arg y]]