<verbatim> # # tmg.tcl - a very small macroprocessor in TCL # # The syntax is a bit stricter than the older TMG, in particular # @$! must occur in the first column. See the wiki for a description. # # performance is not too bad, e.g. # to process 5712 lines, 174819 bytes using tkCanvas.c is around 24ms # on an old laptop. # # Copyright (c) 2020, Phil Maker # # No rights reserved. #

package provide tmg 0.1

proc tmg {s filename} { set prog {} set ::_out {}

set lines split $s \n set nlines llength $lines set lineno 0 set default_first "="

foreach line $lines { incr lineno

if {$lineno < $nlines} { set sep "\\n" } else { set sep "" }

set first string index $line 0 ;# a command character or not set rest string range $line 1 end

if {$first eq "="} { set default_first string range $line 1 1 } elseif {$default_first eq "@"} { ;# plain old code append prog $line \n } elseif {$default_first eq "$"} { ;# $ only append prog "append _out \subst -nocommands -nobackslashes [list $line\] $sep" \n } elseif {$default_first eq "!"} { append prog "append _out \subst [list $rest\] $sep" \n } elseif {$first eq "@"} { append prog $rest \n } elseif {$first eq "$" || $default_first eq "$"} { ;# $ subst only append prog "append _out \subst -nocommands -nobackslashes [list $rest\] $sep" \n } elseif {$first eq "!" || $default_first eq "!"} { ;# $ and commands append prog "append _out \subst [list $rest\] $sep" \n } else { ;# literal append prog "append _out list $line $sep" \n } }

# TODO: maybe add in frink style checking or tclCheck

if {catch [list uplevel #0 $prog r opt]} { array set a $opt set lineno $a(-errorline) if {0} { puts stderr $prog puts stderr "$$$" } %failed "tmg failed with error $r at $filename:$lineno _file_line $filename $lineno" return "" } else { return $r } } </verbatim>