Attachment "lambda3.tcl" to
ticket [940207ffff]
added by
msofer
2004-04-28 18:03:29.
#
# LAMBDA IMPLEMENTATION (TIP 187-alike)
#
#
# Invoking
#
# proc $argList $body
#
# returns a string
#
# "%NS::%Prefix {$argList} {$body}"
#
# which is a token for the corresponding anonymous function
# in canonical form. Note that canonical anon functions live
# in the global namespace ::
#
# %Prefix determines the "flavor" of lambda. Some of the suggested
# variants are:
# %Prefix is lambda ;# closest to the TIP
# %Prefix is apply ;# as in http://mini.net/tcl/11141
# %Prefix is .
# In order to make name collisions extremely unlikely, one could
# also let the Prefix start with #
# %Prefix #
# %Prefix #lambda
#
# The Prefix should not include any double-colon; if you want the
# lambdas to live in a special namespace, set %NS to
# the corresponding namespace - without trailing double-colon.
#
# The name %NS of the service NS determines where the procs and
# variables that implement the new behaviour will live.
#
# The variable %Auto controls if auto-expansion should be done
# for all multi-word commands.
#
# The body of a lambda runs in its own environment (identical to a
# proc-body environment), with namespace context given by its name:
# {::ns1::ns2::%Prefix $argList $body}
# ie, %NS by default.
#
# [map], [filter], and other higher-order functions should evaluate
# in their caller's context (ie, uplevel 1).
set LambdaMap [list \
%Prefix lambda \
%NS {} \
%LambdaNS ::lambda \
%Auto 1 \
]
#
# The code tries to interpret as lambda expressions the command
# names that satisfy
# (0) set tail [namespace tail $cmdName]
# (1) [llength $tail] == 3
# (1) [lindex $tail 0] == %Prefix
# (2) proc $cmdName [lindex $tail 1] [lindex $tail 2]
# succeeds
#
# Cleanup, useful for reloading
#
catch [string map $LambdaMap {
if {[info exists %LambdaNS::OrigUnknownBody]} {
proc ::unknown args $%LambdaNS::OrigUnknownBody
}
if {[info command %LambdaNS::OrigProc] ne {}} {
rename proc {}
rename %LambdaNS::OrigProc proc
}
namespace delete %LambdaNS
}]
namespace eval [string map $LambdaMap %LambdaNS] [string map $LambdaMap {
#
# Cmd names cannot contain double-colon, so
# that we are forced to quote them.
#
proc Quote body {string map {: {\:}} $body}
proc Unquote body {string map {{\:} :} $body}
proc SingleQuote body {Quote [Unquote $body]}
#
# Some service procs
#
# AutoCleaningProc: implements the auto-GC behaviour
if {[info command ::tcl::unsupported::AutoCleaningCmd] ne {}} {
interp alias {} %LambdaNS::AutoCleaningCmd {} ::tcl::unsupported::AutoCleaningCmd
} else {
proc AutoCleaningCmd args {}
}
proc MakeAutoCleaningProc {name argList body} {
if {[uplevel 1 [list info command $name]] == {}} {
uplevel 1 [list proc $name $argList $body]
}
uplevel 1 [list %LambdaNS::AutoCleaningCmd $name 1]
}
# IsLambda
proc IsLambda name {
# CAREFUL: do not shimmer
set name [namespace tail ::$name]; # NO SHIMMER
if {[catch {set len [llength $name]}] \
|| ($len < 3) \
|| ([lindex $name 0] ne "%Prefix")} {
return 0
}
set argList [lindex $name 1]
foreach val $argList {
if {[llength $val] > 2} {
return 0
}
}
return 1
}
# SetCleanupTraces: used to manage lifetime of
# some dependent lambdas
namespace eval %LambdaNS::refs {}
proc SetCleanupTraces {name lambdas} {
set refName %LambdaNS::refs::[namespace tail ::$name]
set $refName $lambdas
trace add command $name delete \
[list unset -nocomplain $refName]
}
#
# MakeCmdFromLambda: the main lambda and curry processor,
# invoked from ::unknown
#
proc MakeCmdFromLambda cmdName {
set OK 0
set ns [namespace qualifiers $cmdName]
if {$ns ne {}} {
append ns ::
}
set tail [namespace tail ::$cmdName]; # NO SHIMMER
if {[IsLambda $cmdName]} {
set curry [lassign $tail prefix argList body]
if {[llength $curry]} {
set name $ns[proc $argList $body]
} else {
set name $cmdName
}
if {[uplevel 1 [list info command $name]] eq {}} {
set script [list %LambdaNS::MakeAutoCleaningProc $name \
$argList [Unquote $body]]
set OK [expr {![catch {uplevel 1 $script}]}]
} else {
set OK 1
}
if {$OK && [llength $curry]} {
set script [list %LambdaNS::MakeAutoCleaningProc $cmdName \
args "[list $name] {expand}$curry \{expand\}\$args"]
set OK [expr {![catch {uplevel 1 $script}]}]
if {$OK} {
SetCleanupTraces $cmdName [list $name]
}
}
} elseif %Auto {
#
# Curry (or autoexpand) a command?
#
set curry [lassign $tail name]
set name ${ns}$name
if {[llength $curry]} {
set script [list %LambdaNS::MakeAutoCleaningProc $cmdName \
args "[list $name] {expand}$curry \{expand\}\$args"]
set OK [expr {![catch {uplevel 1 $script}]}]
}
}
set OK
}
#
# Defined only so that auto-expansion is emulated also for
# lambda expressions
#
if %Auto {
proc ::apply {argList body args} {
# FIXME: to be done
}
}
#
# Redefine::unknown to obtain the behaviour
#
proc Unknown args {
set cmdName [lindex $args 0]
if {[llength [namespace tail $cmdName]] > 1} {
if {[uplevel 2 [list %LambdaNS::MakeCmdFromLambda $cmdName]]} {
return -code return [uplevel 2 $args]
}
}
}
set OrigUnknownBody [info body ::unknown]
proc ::unknown args "
%LambdaNS::Unknown \{expand\}\$args
$OrigUnknownBody
"
#
# Replace the original proc to implement the
# new behaviour.
#
catch {rename OrigProc {}}
rename ::proc OrigProc
OrigProc ::proc args {
if {[llength $args] == 2} {
#
# Anonymous fuction request; just produce the
# string, and let [unknown] handle the rest at
# first use.
#
lassign $args argList body
return "%NS::%Prefix {$argList} {[%LambdaNS::Quote $body]}"
}
#
# Normal tcl proc
#
uplevel 1 [list %LambdaNS::OrigProc {expand}$args]
}
#
# Some useful thingies
#
# OPTIMISATION: to reduce recompilation when shimmering, you
# may choose to manage the existence of the lambda under script
# control. The following commands convert a lambda to a proc,
# and viceversa - insuring the survival of the bytecodes.
proc preserve lam {
if {([uplevel 1[list info command $lam]] ne {}) \
|| (([%LambdaNS::IsLambda $lam]) \
&& ([uplevel 1 [list %LambdaNS::MakeCmdFromLambda $lam]]))} {
uplevel 1 [list %LambdaNS::AutoCleaningCmd $lam 0]
}
}
proc release lam {
if {([uplevel 1 [list info command $lam]] ne {}) \
&& ([%LambdaNS::IsLambda $lam])} {
uplevel 1 [list %LambdaNS::AutoCleaningCmd $lam 1]
}
}
# map
proc map {func lst} {
preserve $func
set ret [list]
foreach item $lst {
lappend ret [uplevel 1 [list $func $item]]]
}
release $func
set ret
}
# Function composition; takes a list of procs or lambdas, creates the
# composite function as a lambda. It keeps references to the internal
# lambdas, in order to provide lifetime management.
#
# Note: all but the last function should be able to handle a single
# argument.
#
proc o {x y args} {
set args [linsert $args 0 $x $y]
set num [llength $args]
set lambdas [list]
set body {}
foreach fun $args {
if {[IsLambda $fun]} {
lappend lambdas $fun
if {[uplevel 1 [list info command $fun]] eq {}} {
uplevel 1 [list %LambdaNS::MakeCmdFromLambda $fun]
}
}
append body "uplevel 1 \[list [list $fun] \["
}
set num [expr {2*$num-1}]
set body [string replace $body end end \
" \{expand\}\$args [string repeat \] $num]"]
set cmdName [proc args $body]
if {[uplevel 1 [list %LambdaNS::MakeCmdFromLambda $cmdName]] \
&& [llength $lambdas]} {
SetCleanupTraces $cmdName $lambdas
}
set cmdName
}
}]
unset LambdaMap
