#
# KMG (03 Sep 2005) - back-port of sugar 0.1 to Tcl8.3
#
# 1) Changed all ' eq ' to ' == '
# 2) Changed all ' ne ' to ' != '
# 3) Source lset.tcl and lindex.tcl to emulate the 8.4 versions of those commands
#
# Runs the standard example files shipped with sugar (except dictsugar.tcl which requires 8.5)
#
source [file join [file dirname [info script]] lset.tcl]
source [file join [file dirname [info script]] lindex.tcl]
# Sugar - a macro system for Tcl
# Copyright (C) 2004 Salvatore Sanfilippo
# Under the same license as Tcl version 8.4
### Changes
#
# 25Mar2004 - Added support for unique identifiers (sugar::uniqueName).
# 25Mar2004 - Now macros can specify a list of arguments instead of
# a unique argument that will receive a list. For old behaviour
# just use 'args'.
# 24Mar2004 - Modified the tailcal_proc transformer to use [foreach] for
# multiple assignments instead to create temp vars. Thanks
# to Richard Suchenwirth for the suggestion.
### TODO
#
# - better macro error reporting (line numbers).
# - call the macro system recursively for variable expansions?
# this allows to expand syntax that have to deal with
# variables interpolated inside other strings. (probably not).
# - Write a better macro for [switch] using sugar::scriptToList.
# - Write a macro that convert a subset of Tcl to critcl.
# - sugar::interleaveSpace should remove spaces before the first
# element of type TOK from the original parsed command.
# This is not needed for simple macro expansion because the
# sugar::expand function does this automatically, but it's needed
# when playing raw with the output of sugar::scriptToList.
# - Investigate on indentation changes with the tailrec macro
# (DONE: Fixed thanks to another related bug found by NEM).
# - An API to provide unique variable names for macro expansions.
package provide sugar 0.1
namespace eval sugar {}
namespace eval sugar::macro {}
namespace eval sugar::syntaxmacro {}
namespace eval sugar::transformermacro {}
# An incremental id used to create unique identifiers.
set sugar::unique_id 0
# This global variable contains the name of the procedure being
# expanded.
set sugar::currentprocedure {}
# Return the fully-qualified name of the current procedure.
proc sugar::currentProcName {} {
return $sugar::currentprocedure
}
# Return the "tail" of the current procedure name.
proc sugar::currentProcTail {} {
namespace tail $sugar::currentprocedure
}
# Return the namespace of the current procedure name.
proc sugar::currentProcNamespace {} {
namespace qualifiers $sugar::currentprocedure
}
# Return an unique identifier that macros can use as variable/proc names.
proc sugar::uniqueName {} {
set id [incr sugar::unique_id]
return __sugarUniqueName__$id
}
# Initialize the state of the interpreter.
# Currently this parser is mostly stateless, it only needs
# to save the type of the last returned token to know
# if something starting with '#' is a comment or not.
proc sugar::parserInitState statevar {
upvar $statevar state
set state [list EOL]
}
# The parser. It does not discard info about space and comments.
# The return value is the "type" of the token (EOF EOL SPACE TOKEN).
#
# It may be interesting to note that this is half of a simple
# Tcl interpreter. variable expansions is ignored, while command
# expansion is performed expanding macros if needed.
#
# The fact that it is still so simple, compared to what it can
# be in Python just to say one (much worst in Perl), it's an advice
# that to add syntax to Tcl is a bad idea.
proc sugar::parser {text tokenvar indexvar statevar {dosubst 0}} {
upvar $tokenvar token $indexvar i $statevar state
set token {}
set inside {}
set dontstop $dosubst
while 1 {
# skip spaces
while {!$dontstop && [string match "\[ \t\]" [string index $text $i]]} {
append token [string index $text $i]
incr i
}
# skip comments
if {$state == {EOL} && !$dontstop && [string equal [string index $text $i] #]} {
while {[string length [string index $text $i]] &&
![string match [string index $text $i] \n]} \
{
append token [string index $text $i]
incr i
}
}
# return a SPACE token if needed
if {[string length $token]} {return [set state SPACE]}
# check for special conditions
if {!$dontstop} {
switch -exact -- [string index $text $i] {
{} {return [set state EOF]}
{;} -
"\n" {
append token [string index $text $i]
incr i
return [set state EOL]
}
}
}
# main parser loop
while 1 {
switch -exact -- [string index $text $i] {
{} break
{ } -
"\t" -
"\n" -
";" {
if {!$dontstop} {
break;
}
}
\\ {
incr i
append token \\ [string index $text $i]
incr i
continue
}
\" {
if {[string equal $inside {}]} {
incr dontstop
set inside \"
append token \"
incr i
continue
} elseif {[string equal $inside \"]} {
incr dontstop -1
set inside {}
append token \"
incr i
continue
}
}
"\{" {
if {[string equal $inside {}]} {
incr dontstop
set inside "\{"
append token "\{"
incr i
continue
} elseif {[string equal $inside "\{"]} {
incr dontstop
}
}
"\}" {
if {[string equal $inside "\{"]} {
incr dontstop -1
if {$dontstop == 0} {
set inside {}
append token "\}"
incr i
continue
}
}
}
\$ {
if {![string equal $inside "\{"]} {
if {![string equal [string index $text [expr {$i+1}]] $]} {
set res [LctSubstVar $text i]
append token "$$res"
continue
}
}
}
\[ {
if {![string equal $inside "\{"]} {
set res [LctSubstCmd $text i]
append token "\[$res\]"
continue
}
}
}
append token [string index $text $i]
incr i
}
return [set state TOK]
}
}
# Actually does not really substitute commands, but
# exapands macros inside.
proc LctSubstCmd {text indexvar} {
upvar $indexvar i
set go 1
set cmd {}
incr i
while {$go} {
switch -exact -- [string index $text $i] {
{} break
\[ {incr go}
\] {incr go -1}
}
append cmd [string index $text $i]
incr i
}
set cmd [string range $cmd 0 end-1]
return [::sugar::expand $cmd]
}
# Get the control when a '$' (not followed by $) is encountered,
# extract the name of the variable, and return it.
proc LctSubstVar {text indexvar} {
upvar $indexvar i
set dontstop 0
set varname {}
incr i
while {1} {
switch -exact -- [string index $text $i] {
\[ -
\] -
"\t" -
"\n" -
"\"" -
\; -
\{ -
\} -
\$ -
( -
) -
{ } -
"\\" -
{} {
if {!$dontstop} {
break
}
}
( {incr dontstop}
) {incr dontstop -1}
default {
append varname [string index $text $i]
}
}
incr i
}
return $varname
}
# Return the number of lines in a string
proc countlines {string} {
llength [split $string "\n"]
}
# interleave SPACE and EOL tokens in a Tcl list $tokens
# representing a command. Also every token is
# converted to the two-elements list representation
# with type TOK.
#
# The $origargv list is the output of the parser
# for that command, and is used by interleaveSpaces
# to make the indentation of the expanded macro as
# similar as possible to what the used typed in the source
# code.
proc sugar::interleaveSpaces {tokens origargv} {
set newargv {}
for {set j 0} {$j < [llength $tokens]} {incr j} {
lappend newargv [list TOK [lindex $tokens $j]]
set idx [::sugar::indexbytype $origargv SPACE $j]
if {$idx == -1} {
lappend newargv [list SPACE " "]
} else {
# If possible, try to use the same argument
# separator as the user typed it.
lappend newargv [lindex $origargv $idx]
}
}
# Use the same EOL string. That's always possible
if {![llength $newargv]} {
set newargv [list ";"]
}
lset newargv end [lindex $origargv end]
return $newargv
}
# Transform a script to a list of lists, where every list is
# a command, and every element of the list is an argument,
# and is itself a two elements of list. The first element
# is the token type, the second the toke value. The following
# toke types are defined.
#
# SPACE - Spaces, non significative for the execution, just separate arguments.
# TOK - Any significative token. The first element of type TOK is
# the command name.
# EOL - End of line.
#
# This function is intended to be used directly or indirectly by macro,
# that will do the processing, and then call listToScript to convert
# it back in script.
#
# Macros may want to call sugar::tokens for every command to work
# more comfortably with it, and than reconvert to the
# original format with sugar::interleaveSpaces.
#
# ----------------------------------------------------------------------
# In theory sugar::expand should be modified to directly use this
# instead of a local copy of almost the same code. They are actually
# a bit different because sugar::expand does the processing for every
# command, not in the entire script at once.
proc sugar::scriptToList script {
set i 0
set result {}
::sugar::parserInitState parserState
set eof 0
while 1 {
set command {}
while 1 {
set type [::sugar::parser $script token i parserState]
switch $type {
EOF {lappend command [list EOL {}]; set eof 1; break}
default {
lappend command [list $type $token]
if {$type == {EOL}} break
}
}
}
lappend result $command
if {$eof} break
}
return $result
}
# That's really trivial ;)
# The macro specification should guarantee that the list
# is transformed into the source code by simple concatenation
# of all the tokens.
proc sugar::listToScript list {
set result {}
foreach c $list {
foreach t $c {
append result [lindex $t 1]
}
}
return $result
}
# Return true if the named macro exists, and store in macroName var
# the fully qualified name of the procedure in charge to do expansion for it.
proc sugar::lookupMacro {macroname procnameVar} {
upvar 1 $procnameVar procname
if {[catch {info args ::sugar::macro::__macroproc__$macroname}]} {
return 0
}
set procname ::sugar::macro::__macroproc__$macroname
return 1
}
# Macro expansion. It trys to take indentation unmodified.
proc sugar::expand script {
while 1 {
set eof 0
set i 0
set result {}
::sugar::parserInitState parserState
while {!$eof} {
set argv {}
set argc 0
# Collect a command in $argv. Every token is a two-elements
# List with the token type and value, as returned by expr.
# Significative tokens are interleaved with space tokens:
# syntax macros will have a way to know how arguments where
# separated.
while 1 {
set type [::sugar::parser $script token i parserState]
if {[string equal $type EOF]} {
set eof 1
}
switch $type {
EOF {lappend argv [list EOL {}]; break}
default {
if {$type == {SPACE} && $argc == 0} {
append result $token
} else {
lappend argv [list $type $token]
incr argc
if {$type == {EOL}} break
}
}
}
}
# Call macros for this statement
if {[lindex $argv 0 0] != {EOL}} {
# Check if there is a macro defined with that name
set cmdname [lindex $argv 0 1]
# Call the macro associated with that command name, if any.
if {[sugar::lookupMacro $cmdname expander]} {
#puts "executing macro for $cmdname in procedure [::sugar::currentProcName]"
if {[catch {set tokens [eval $expander [::sugar::tokens $argv]]} errstr]} {
error "Macro '$cmdname' expansion error in procedure '$::sugar::currentprocedure': $errstr" $::errorInfo
}
set argv [::sugar::interleaveSpaces $tokens $argv]
}
# Call all the syntax macros. For now in random order.
foreach syntaxmacro [info command ::sugar::syntaxmacro::__macroproc__*] {
set argv [::sugar::interleaveSpaces [eval $syntaxmacro [::sugar::tokens $argv]] $argv]
}
}
foreach arg $argv {
append result "[lindex $arg 1]"
}
}
# Call all the transformer macros. For now in random order.
# TODO: consider if it's better to move this as first
# transformation.
foreach trmacro [info command ::sugar::transformermacro::__macroproc__*] {
set list [::sugar::scriptToList $result]
set list [$trmacro $list]
set result [::sugar::listToScript $list]
}
# Reiterate if needed, otherwise exit.
if {[string equal $script $result]} break
#puts "AFTER: '$script'"
#puts "BEFORE: '$result'"
#puts "---"
set script $result
}
return $result
}
# Return the index of the $num-Th element of type $type in a list
# of tokens.
proc ::sugar::indexbytype {argv type num} {
set idx 0
foreach a $argv {
foreach {t _} $a break
if {$type == $t} {
if {!$num} {
return $idx
}
incr num -1
}
incr idx
}
return -1
}
# Wrapper for [proc] that expands macro in the body
# TODO: add a switch -nomacro to avoid macro expansion
# for the given procedure.
proc sugar::proc {name arglist body} {
# Get the fully qualified name of the proc
set ns [uplevel [list namespace current]]
# If the proc call did not happen at the global context and it did not
# have an absolute namespace qualifier, we have to prepend the current
# namespace to the command name
if { ![string equal $ns "::"] } {
if { ![string match "::*" $name] } {
set name "${ns}::${name}"
}
}
if { ![string match "::*" $name] } {
set name "::$name"
}
set oldprocedure $::sugar::currentprocedure
set ::sugar::currentprocedure $name
# puts "+ $name"
set body [::sugar::expand $body]
# Call the real [proc] command.
uplevel 1 [list ::proc $name $arglist $body]
set ::sugar::currentprocedure $oldprocedure
return
}
# Number of tokens of type TOK. Useful for arity checking in macros.
proc sugar::tokensnum argv {
set c 0
foreach a $argv {
if {[lindex $a 0] == {TOK}} {
incr c
}
}
return $c
}
# Return values of all the tokens of type TOK as a list.
proc sugar::tokens argv {
set tokens {}
foreach a $argv {
if {[lindex $a 0] == {TOK}} {
lappend tokens [lindex $a 1]
}
}
return $tokens
}
# Define a new macro
proc sugar::macro {names arglist body} {
foreach name $names {
uplevel 1 [list ::proc ::sugar::macro::__macroproc__$name $arglist $body]
}
}
# Define a new syntax macro
proc sugar::syntaxmacro {name arglist body} {
uplevel 1 [list ::proc ::sugar::syntaxmacro::__macroproc__$name $arglist $body]
}
# Define a new transformer macro
proc sugar::transformermacro {name arglist body} {
uplevel 1 [list ::proc ::sugar::transformermacro::__macroproc__$name $arglist $body]
}
# That's used to create macros that expands arguments that are
# scripts. This kind of macros are used for [while], [for], [if],
# and so on.
proc sugar::expandScriptToken tok {
set t [lindex $tok 0]
set res [::sugar::expand $t]
if {[string equal $t $res]} {
return $tok
} else {
list $res
}
}
# Macro substitution. Like [subst] but for macros.
proc sugar::dosubst string {
sugar::parserInitState state
set idx 0
sugar::parser $string result idx state 1
return $result
}
# Expand Expr's expressions. Try to don't mess with quoting.
proc sugar::expandExprToken tok {
set quoted 0
if {[string index $tok 0] == "\{" && [string index $tok end] == "\}"} {
set quoted 1
set tok [string range $tok 1 end-1]
}
set tok [sugar::dosubst $tok]
if {$quoted} {
set tok "{$tok}"
}
return $tok
}
# Get the N-th element with type $type from the list of tokens.
proc sugar::gettoken {argv type n} {
set idx [::sugar::indexbytype $argv $type $n]
if {$idx == -1} {
error "bad index for gettoken (wrong number of args for macro?)"
}
lindex $argv $idx 1
}
# Set the N-th $type element in the list of tokens to the new $value.
proc sugar::settoken {argvVar type n value} {
upvar $argvVar argv
set idx [::sugar::indexbytype $argv $type $n]
if {$idx == -1} {
error "bad index for gettoken (wrong number of args for macro?)"
}
lset argv $idx 1 $value
}
################################################################################
# Macros to allow macros inside conditionals, loops and other Tcl commands
# that accept scripts or [expr] expressions as arguments.
################################################################################
sugar::macro while args {
lset args 1 [sugar::expandExprToken [lindex $args 1]]
lset args 2 [sugar::expandScriptToken [lindex $args 2]]
}
sugar::macro foreach args {
lset args end [sugar::expandScriptToken [lindex $args end]]
}
sugar::macro time args {
lset args 1 [sugar::expandScriptToken [lindex $args 1]]
}
sugar::macro if args {
lappend newargs [lindex $args 0]
lappend newargs [sugar::expandExprToken [lindex $args 1]]
set args [lrange $args 2 end]
foreach a $args {
switch -- $a {
else - elseif {
lappend newargs $a
}
default {
lappend newargs [sugar::expandScriptToken $a]
}
}
}
return $newargs
}
sugar::macro for args {
lset args 1 [sugar::expandScriptToken [lindex $args 1]]
lset args 3 [sugar::expandScriptToken [lindex $args 3]]
lset args 4 [sugar::expandScriptToken [lindex $args 4]]
return $args
}
# That's still not perfect because messes with indentation.
# Should use new scriptToList API to do it better.
sugar::macro switch args {
lappend result [lindex $args 0]
set idx 0
set isquoted 0
while 1 {
incr idx
set arg [lindex $args $idx]
if {$arg == {--}} {
lappend result $arg
incr idx
break
}
if {[string index $arg 0] != {-}} break
lappend result $arg
}
lappend result [lindex $args $idx]
incr idx
# Handle the two forms in two different ways
if {[llength $args]-$idx == 1} {
set l [lindex $args $idx 0]
set isquoted 1
} else {
set l [lrange $args $idx end]
}
# Expand scripts inside
set temp {}
foreach {pattern body} $l {
if {$body != {-}} {
if {$isquoted} {
set body [lindex [sugar::expandScriptToken [list $body]] 0]
} else {
set body [sugar::expandScriptToken $body]
}
}
lappend temp $pattern $body
}
# Requote it if needed.
if {$isquoted} {
return [concat $result [list [list $temp]]]
} else {
return [concat $result $temp]
}
}
################################################################################
# Transformers included in sugar
################################################################################
################ a macro for tail recursion ##############
# TODO: give a name to this kind of macros, and maybe provide
# a function to 'encapsulate' the common part of this
# kind of macros involving the redefinition of proc.
proc sugar::tailrecproc {name arglist body} {
# Convert the script into a Tcl list
set l [sugar::scriptToList $body]
# Convert tail calls
set l [sugar::tailrec_convert_calls $name $arglist $l]
# Add the final break
lappend l [list {TOK break} {EOL "\n"}]
# Convert it back to script
set body [sugar::listToScript $l]
# Add the surrounding while 1
set body "while 1 {$body}"
# Call [proc]
uplevel ::proc [list $name $arglist $body]
}
# Convert tail calls. Helper for tailrec_proc.
# Recursively call itself on [if] script arguments.
proc sugar::tailrec_convert_calls {name arglist code} {
# Search the last non-null command.
set lastidx -1
for {set j 0} {$j < [llength $code]} {incr j} {
set cmd [lindex $code $j]
if {[sugar::indexbytype $cmd TOK 0] != -1} {
set lastidx $j
set cmdidx [sugar::indexbytype $cmd TOK 0]
}
}
if {$lastidx == -1} {
return $code
}
set cmd [lindex $code $lastidx]
set cmdname [lindex $cmd $cmdidx 1]
if {[lindex $cmd 0 0] == {SPACE}} {
set space [lindex $cmd 0 1]
} else {
set space " "
}
if {$cmdname == $name} {
#puts "TAILCALL -> $cmdname"
set recargs [lrange [sugar::tokens $cmd] 1 end]
set t [list [list SPACE $space] [list TOK foreach] [list SPACE " "]]
lappend t [list TOK "\[list "]
foreach a $arglist {
lappend t [list TOK $a] [list SPACE " "]
}
lappend t [list TOK "\] "]
lappend t [list TOK "\[list "]
foreach a $recargs {
lappend t [list TOK $a] [list SPACE " "]
}
lappend t [list TOK "\] "]
lappend t [list TOK break] [list EOL "\n"]
set code [linsert $code $lastidx $t]
incr lastidx
lset code $lastidx [list [list SPACE $space] [list TOK continue] [list EOL "\n"]]
} elseif {$cmdname == {if}} {
#puts "IF CALL"
for {set j 0} {$j < [llength $cmd]} {incr j} {
if {[lindex $cmd $j 0] != {TOK}} continue
switch -- [lindex $cmd $j 1] {
if - elseif {
incr j 2
}
else {
incr j 1
}
default {
set script [lindex $code $lastidx $j 1]
#puts "$j -> $script"
set scriptcode [sugar::scriptToList [lindex $script 0]]
set converted [sugar::tailrec_convert_calls $name $arglist $scriptcode]
lset code $lastidx $j 1 [list [sugar::listToScript $converted]]
}
}
}
}
return $code
}See Also: sugar, Snit under Tcl/Tk 8.3
