/lib/gaa_lambda.tcl
TCL | 96 lines | 67 code | 12 blank | 17 comment | 11 complexity | db18e7f2dd4fefdd0831969666ac4974 MD5 | raw file
1############################################################################ 2# Copyright (C) 2008 Alexander Galanin <gaa.nnov@mail.ru> # 3# # 4# This program is free software: you can redistribute it and/or modify # 5# it under the terms of the GNU Lesser General Public License as # 6# published by the Free Software Foundation, either version 3 of the # 7# License, or (at your option) any later version. # 8# # 9# This program is distributed in the hope that it will be useful, # 10# but WITHOUT ANY WARRANTY; without even the implied warranty of # 11# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # 12# GNU General Public License for more details. # 13# # 14# You should have received a copy of the GNU Lesser GNU General Public # 15# License along with this program. # 16# If not, see <http://www.gnu.org/licenses/>. # 17############################################################################ 18 19package provide gaa_lambda 1.2 20 21package require Tcl 8.4 22 23namespace eval lambda { 24 25namespace export \ 26 lambda \ 27 deflambda \ 28 closure \ 29 defclosure 30 31proc lambdaLowlevel {paramsVar scriptVar argsVar} { 32 set params [ uplevel [ list set $paramsVar ] ] 33 set script [ uplevel [ list set $scriptVar ] ] 34 set args [ uplevel [ list set $argsVar ] ] 35 uplevel [ list unset $paramsVar $scriptVar $argsVar ] 36 for {set i 0} {$i < [ llength $params ]} {incr i} { 37 if { [ lindex $params $i ] != "args" } { 38 uplevel [ list set [ lindex $params $i ] [ lindex $args $i ] ] 39 } else { 40 uplevel [ list set [ lindex $params $i ] [ lrange $args $i end ] ] 41 } 42 } 43 uplevel [ list eval $script ] 44} 45 46proc lambdaProc {params script args} { 47 if {( [ lindex $params end ] == "args" && [ llength $params ] > [ llength $args ] ) || \ 48 ( [ lindex $params end ] != "args" && [ llength $params ] != [ llength $args ] )} { 49 error "Arguments count mismatch: expected $params, but $args passed." 50 } 51 ::lambda::lambdaLowlevel params script args 52} 53 54proc lambda {params script args} { 55 return [ concat [ list [ namespace current ]::lambdaProc $params $script ] $args ] 56} 57 58proc deflambda {id params script args} { 59 uplevel [ list set $id [ concat [ list [ namespace current ]::lambdaProc $params $script ] $args ] ] 60} 61 62proc closure {locals params script} { 63 set localParams "" 64 set localArgs "" 65 foreach p $locals { 66 lappend localParams $p 67 lappend localArgs [ uplevel [ list set $p ] ] 68 } 69 return [ concat \ 70 [ list [ namespace current ]::lambdaProc \ 71 [ concat $localParams $params ] \ 72 $script \ 73 ] \ 74 $localArgs \ 75 ] 76} 77 78proc defclosure {id locals params script args} { 79 set localParams "" 80 set localArgs "" 81 foreach p $locals { 82 lappend localParams $p 83 lappend localArgs [ uplevel [ list set $p ] ] 84 } 85 uplevel [ concat \ 86 [ list [ namespace current ]::deflambda \ 87 $id \ 88 [ concat $localParams $params ] \ 89 $script \ 90 ] \ 91 $localArgs \ 92 ] 93} 94 95} 96