/lib/gaa_lambda.tcl

 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