Posted to tcl by auriocus at Wed Oct 08 19:32:51 GMT 2014view raw

  1. namespace eval ::auriocus {
  2.  
  3. variable codestore {}
  4.  
  5. proc macro {name margs rtargs mcode} {
  6. # breaks if one of the args is "args"
  7. # or has an odd name like spaces etc.
  8. # no fundamental problem, just laziness and quoting hell overflow
  9. set margnames [lmap m $margs {lindex $m 0}]
  10.  
  11. set codegenproc ::auriocus::mc_$name
  12.  
  13. proc $codegenproc $margnames $mcode
  14.  
  15. set instrcode [string map \
  16. [list %margs [list $margnames] %codegenproc $codegenproc %name $name] {
  17. set margval [lmap __v %margs {set $__v}]
  18. set arghash [list %name $margval]
  19. if {[dict exists $::auriocus::codestore $arghash]} {
  20. set expandedcode [dict get $::auriocus::codestore $arghash]
  21. } else {
  22. set expandedcode [%codegenproc {*}$margval]
  23. dict set ::auriocus::codestore $arghash $expandedcode
  24. }
  25. uplevel 1 $expandedcode
  26. }
  27. ]
  28.  
  29. set combinedargs [list {*}$margs {*}$rtargs]
  30. uplevel 1 [list proc $name $combinedargs $instrcode]
  31. }
  32. }
  33.  
  34. # demo
  35. if 0 {
  36. package require vectcl
  37. # simulate vexpr
  38. auriocus::macro myvexpr vcode {} {
  39. $::vectcl::compiler compile $vcode -novarrefs
  40. }
  41. }
  42.  
  43. # from sugar introduction
  44. auriocus::macro clear {v} {} {
  45. list set $v {{}}
  46. }
  47.  
  48. proc foobar {} {
  49. set x 10
  50. puts "x is now $x"
  51. clear x
  52. puts "x is now $x"
  53. clear y
  54. puts "y is now $y"
  55. }
  56.  
  57. # testing macro runtime parameters
  58. #
  59. auriocus::macro prefixset {var} {val} { return "set _pref_$var \$val" }
  60.  
  61. proc testrtpar {} {
  62. prefixset x 20
  63. puts "Set var: $_pref_x"
  64. }