Posted to tcl by aku at Mon Jul 21 20:00:45 GMT 2008view raw

  1. ## -*- tcl -*-
  2. # ### ### ### ######### ######### #########
  3. ## Support code
  4.  
  5. proc sd {} {
  6. set levels [info frame]
  7. set n 0
  8. puts "-- ---"
  9. while {$levels > 0} {
  10. puts "-- ... [info frame $n]"
  11. incr n -1
  12. incr levels -1
  13. }
  14. puts "-- ---"
  15. return
  16. }
  17.  
  18. # ### ### ### ######### ######### #########
  19.  
  20. proc control {vv script} {
  21. upvar 1 $vv var
  22. set var calling
  23. set x [uplevel 1 $script]
  24. append x /$var
  25. return $x
  26. }
  27.  
  28. # ### ### ### ######### ######### #########
  29.  
  30. proc datal {} {
  31. puts [control y {
  32. set y PPL
  33. puts "$y [sd]"
  34. }]
  35. return
  36. }
  37.  
  38. proc datav {} {
  39. set script {
  40. set y PPV
  41. puts "$y [sd]"
  42. }
  43.  
  44. puts [control y $script]
  45. return
  46. }
  47.  
  48. # ### ### ### ######### ######### #########
  49. ## 6 use cases.
  50.  
  51. puts "## DV. direct-var ##"
  52. puts "## DL. direct-literal ##"
  53. puts "## DPV direct-proc-var ##"
  54. puts "## DPL direct-proc-literal ##"
  55. puts "## PPV proc-proc-var ##"
  56. puts "## PPL proc-proc-literal ##"
  57. puts "# ### ### ### ######### ######### #########"
  58.  
  59. puts "## DV. direct-var ##"
  60. set script {
  61. set y DV.
  62. puts "$y [sd]"
  63. }
  64. puts [uplevel \#0 $script]
  65.  
  66. puts "## DL direct-literal ##"
  67. puts [uplevel \#0 {
  68. set y DL.
  69. puts "$y [sd]"
  70. }]
  71.  
  72. puts "## DPV direct-proc-var ##"
  73. set script {
  74. set y DPV
  75. puts "$y [sd]"
  76. }
  77. puts [control y $script]
  78.  
  79. puts "## DPL direct-proc-literal ##"
  80. puts [control y {
  81. set y DPL
  82. puts "$y [sd]"
  83. }]
  84.  
  85. puts "## PPV proc-proc-var ##"
  86. datav
  87.  
  88. puts "## PPL proc-proc-literal ##"
  89. datal