Posted to tcl by kbk at Thu Dec 26 21:08:04 GMT 2013view raw

  1. # coroutine_iterator.tcl --
  2. #
  3. # Implements a 'foreach' loop that uses a coroutine to manage the
  4. # iteration, and cleans up properly on unusual terminations.
  5. #
  6. # Copyright (c) 2013 by Kevin B. Kenny
  7. #
  8. # See the file "license.terms" for information on usage and redistribution
  9. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10. #
  11. #------------------------------------------------------------------------------
  12.  
  13. package require Tcl 8.6
  14.  
  15. namespace eval coroutine {
  16. namespace eval iterator {
  17. variable gensym 0; # Sequence number for generated symbols
  18. namespace export foreach
  19. }
  20. }
  21.  
  22. # coroutine::iterator::foreach --
  23. #
  24. # Iterate over the results of a coroutine
  25. #
  26. # Usage:
  27. # coroutine::iterator::foreach var initCommand script
  28. #
  29. # Parameters:
  30. # var - Name of the variable in caller's scope that
  31. # will hold the values the procedure is iterating over.
  32. # initCommand - Command and arguments that will be the main
  33. # procedure of the coroutine. The procedure is
  34. # expected to yield each of the iteration results
  35. # in turn, and then return to indicate the end of
  36. # the loop.
  37. # script - Script to execute for each [yield]ed value, with
  38. # the [yield]ed value in $var.
  39. #
  40. # Results:
  41. # None.
  42. #
  43. # Side effects:
  44. # Launches a coroutine with the given 'initCommand' and runs
  45. # it to completion, executing the given script one on each
  46. # [yield]ed result.
  47.  
  48. proc coroutine::iterator::foreach {var initCommand script} {
  49. variable gensym
  50. set coro [namespace current]::coro[incr gensym]
  51. upvar 1 $var value
  52. try {
  53. for {set value [coroutine $coro {*}$initCommand]} \
  54. {[namespace which $coro] ne {}} \
  55. {set value [$coro]} {
  56. try {
  57. uplevel 1 $script
  58. } on error {message options} {
  59. dict incr options -level 1
  60. return -options $options $message
  61. } on return {retval options} {
  62. dict incr options -level 1
  63. return -options $options $retval
  64. } on break {} {
  65. break
  66. } on continue {} {
  67. continue
  68. }
  69. }
  70. } finally {
  71. catch {rename $coro {}}
  72. }
  73. }
  74.  
  75. package provide coroutine::iterator 1.0
  76.  
  77. if {![info exists ::argv0] || $::argv0 ne [info script]} {
  78. return
  79. }
  80.  
  81. # Example:
  82.  
  83. proc doit {n} {
  84. for {set i 0} {$i < $n} {incr i} {
  85. yield $i
  86. }
  87. return
  88. }
  89.  
  90. coroutine::iterator::foreach x {doit 10} {puts $x}
  91.