#!/usr/bin/tclsh set cur_class "" proc flatten {lst} { set result "" set separator "" foreach elt [lindex $lst 0] { if {$elt == "="} { break } if {$elt == ","} { append result "${elt}" } else { append result "${separator}${elt}" } set separator " " } return $result } proc value {lst} { set go "" foreach elt $lst { if { $go != "" } { return $elt } if { $elt == "=" } { set go "yup" } } return "" } proc // {args} { puts "// $args" } proc class {name args} { global cur_class cur_vars set cur_class $name puts "class $name [lrange $args 0 [expr [llength $args] - 2]]" puts "{" uplevel [lindex $args end] puts "};" set cur_class "" } proc public: {} { puts "public:" } proc private: {} { puts "private:" } proc int {name args} { puts " int $name [flatten $args];" global cur_vars set cur_vars($name) [value $args] } proc string {name args} { puts " std::string $name [flatten $args];" global cur_vars set cur_vars($name) [value $args] } proc ctor {args} { global cur_class cur_vars puts " ${cur_class}([flatten $args])" puts " {" set had_vars [list] set cur_tp "" set cur_nam "" foreach elt [lindex $args 0] { if { $elt == "," } { set cur_tp "" set cur_nam "" continue } if { $cur_tp == "" } { set cur_tp $elt continue } if { $cur_nam == "" } { set cur_nam $elt puts " m_${cur_nam}= ${cur_nam};" lappend had_vars "m_$cur_nam" continue } } foreach var [array names cur_vars] { if { [lsearch $had_vars $var] < 0 } { set v $cur_vars($var) if { $v != "" } { puts " ${var}= $v;" } } } puts " }" } // This looks vaguely like a C++ class, but it's actually Tcl! class Dog : public Animal { private: int m_age = 5; string m_name; public: ctor {} ctor {int age} ctor {int age , string name} };