benchmarks/brainfuck2/bf_oo.tcl at 22e854cc17d5552019a10c9c686deeb232899759 · kostya/benchmarks · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
package require Tcl 8.6

namespace eval bf {} {
    ::oo::class create Tape {
        variable tape pos

        constructor {} {
            set tape 0
            set pos 0
        }

        method current {} {
            return [lindex $tape $pos]
        }

        method inc x {
            lset tape $pos [expr {[lindex $tape $pos] + $x}]
        }

        method move x {
            incr pos $x
            while {$pos >= [llength $tape]} {
                lappend tape 0
            }
        }
    }

    proc parse source {
        set res {}
        while 1 {
            set c [lindex $source 0]
            if {$c eq {}} break
            set source [lrange $source 1 end]
            switch -exact -- $c {
                + { lappend res [list INC 1] }
                - { lappend res [list INC -1] }
                > { lappend res [list MOVE 1] }
                < { lappend res [list MOVE -1] }
                . { lappend res [list PRINT {}] }
                \[ {
                    lassign [parse $source] loop_code source
                    lappend res [list LOOP $loop_code]
                }
                \] { break }
                default {}
            }
        }
        return [list $res $source]
    }

    proc run {program tape} {
        foreach x $program {
            lassign $x op val
            switch -exact -- $op {
                INC {
                    $tape inc $val
                }
                MOVE {
                    $tape move $val
                }
                PRINT {
                    puts -nonewline [format %c [$tape current]]
                    flush stdout
                }
                LOOP {
                    while {[$tape current] > 0} {
                        run $val $tape
                    }
                }
            }
        }
    }
}

proc main text {
    lassign [::bf::parse $text] program
    set tape [::bf::Tape new]
    ::bf::run $program $tape
    $tape destroy
}

proc notify msg {
    catch {
        set sock [socket "localhost" 9001]
        puts $sock $msg
        close $sock
    }
}

lassign $argv filename
set f [open $filename]
set text [split [read $f] {}]
close $f

notify [format "%s\t%d" "Tcl (OO)" [pid]]
main $text
notify "stop"