Posted to tcl by dbohdan at Fri Jan 27 22:50:24 GMT 2017view raw

  1. package require Tcl 8.6
  2.  
  3. namespace eval bf {}
  4. namespace eval bf::tape {
  5. variable data
  6. variable pos
  7.  
  8. proc current {} {
  9. variable data
  10. variable pos
  11.  
  12. return [lindex $data $pos]
  13. }
  14.  
  15. proc inc x {
  16. variable data
  17. variable pos
  18.  
  19. lset data $pos [expr {[current] + $x}]
  20. }
  21.  
  22. proc move x {
  23. variable data
  24. variable pos
  25.  
  26. incr pos $x
  27. while {$pos >= [llength $data]} {
  28. lappend data 0
  29. }
  30. }
  31. }
  32.  
  33. namespace eval bf {
  34. proc parse source {
  35. set res {}
  36. while 1 {
  37. set c [lindex $source 0]
  38. if {$c eq {}} break
  39. set source [lrange $source 1 end]
  40. switch -exact -- $c {
  41. + { lappend res [list INC 1] }
  42. - { lappend res [list INC -1] }
  43. > { lappend res [list MOVE 1] }
  44. < { lappend res [list MOVE -1] }
  45. . { lappend res [list PRINT {}] }
  46. \[ {
  47. lassign [parse $source] loop_code source
  48. lappend res [list LOOP $loop_code]
  49. }
  50. \] { break }
  51. default {}
  52. }
  53. }
  54. return [list $res $source]
  55. }
  56.  
  57. proc run program {
  58. foreach x $program {
  59. lassign $x op val
  60. switch -exact -- $op {
  61. INC {
  62. tape::inc $val
  63. }
  64. MOVE {
  65. tape::move $val
  66. }
  67. PRINT {
  68. puts -nonewline [format %c [tape::current]]
  69. flush stdout
  70. }
  71. LOOP {
  72. while {[tape::current] > 0} {
  73. run $val
  74. }
  75. }
  76. }
  77. }
  78. return
  79. }
  80. }
  81.  
  82. proc main argv {
  83. lassign $argv filename
  84. set f [open $filename]
  85. lassign [::bf::parse [split [read $f] {}]] program
  86. close $f
  87. set ::bf::tape::data 0
  88. set ::bf::tape::pos 0
  89. ::bf::run $program
  90. }
  91.  
  92. main $argv
  93.