procedure decorators

Zarutian tormented kbk the other day (late Desember 2007 or early January 2008) with this:

 package Tcl 8.5
 variable storage {}
 proc restore {caller vars} {
   if {![dict exists $::storage $caller]} { return }
   foreach var $vars {
     uplevel 1 [list set $var [dict get $::storage $caller $var]]
   }
 }
 proc save {caller vars} {
   foreach var $vars {
     dict set ::storage $caller $var [uplevel 1 [list set $var]]
   }
 }

 proc persist {args} {
   set vars $args; unset args
   if {[uplevel 1 [list info exists __[info level 0]]]} { return }
   uplevel 1 [list set __[info level 0] exists]

   set caller [lindex [info level 1] 0]
   uplevel 1 [list restore $caller $vars]
   catch [list uplevel 1 [info body $caller]] result options
   uplevel 1 [list save $caller $vars]
   dict incr options -level +2
   return -options $options $result 
 }

 proc prufa {args} {
   persist si
   incr si 42
   puts "si = $si"
 }

another well known procedure decorator is memoize, but that only works for referentially transparent functions (i.e. side-effect free procedures).

DKF: So what does this code do? It's not at all clear from just reading the code...

RS: Could it have to do with static variables? But I don't understand the code either...

Zarutian: indeed the above example of an decorator is for persisting static variables.

Zarutian adds an memoize decorator:

 # not tested yet

 package require Tcl 8.5
 variable memoize_storage {}
 proc memoize {} {
   if {[uplevel 1 [liss info exists __[info level 0]]} { return }
   uplevel 1 [list set __[info level 0] exists]

   variable memoize_storage

   set invocation [info level 1]
   if {[dict exists $memoize_storage $invocation]]} {
     set result  [dict get $memoize_storage $invocation result]
     set options [dict get $memoize_storage $invocation return_options]
   } else {
     set caller [lindex $invocation 0]
     catch [list uplevel 1 [info body $caller]] result options
     dict set memoize_storage $invocation result $result
     dict set memoize_storage $invocation return_options $options
   }
   dict incr options -level +2
   return -options $options $result 
 }

kruzalex Example above adapted on Tcl 8.4 with some modifications:

 #tested

 package require dict

 variable memoize_storage {}
 proc memoize {args} {
   set vars $args; unset args
   foreach var $vars break
   if {[uplevel 1 [list info exists __[info level 0]]]} {return }
   uplevel 1 [list set __[info level 0] exists]

   variable memoize_storage

   set invocation [info level 1]
   set caller [lindex $invocation 0]
   set procname [lindex [info level -1] 0]
   if {[dict exists $memoize_storage $caller]} {
   set result [uplevel 1 [list set $var [dict get $memoize_storage $caller $var]]]
   catch [list uplevel 1 [info body $caller]] result 
   dict set memoize_storage $caller $var [uplevel 1 [list set $var]]
   } else {
   catch [list uplevel 1 [info body $caller]] result 
   dict set memoize_storage $caller $var [uplevel 1 [list set $var]]  
   } 
   return -code return $result
 }

  proc prufa {{si 0}} {
   memoize si
   incr si 42
   puts "si = $si"
 }

prufa prufa prufa

kruzalex For Tcl 8.4 lovers example mentioned on the top should work in this way

package require dict

 variable storage {}
 proc restore {caller vars} {
   if {![dict exists $::storage $caller]} { return }
   foreach var $vars {
     uplevel 1 [list set $var [dict get $::storage $caller $var]]
   }
 }
 proc save {caller vars} {
   foreach var $vars {
     dict set ::storage $caller $var [uplevel 1 [list set $var]]
   }
 }

 proc persist {args} {
   set vars $args; unset args
   if {[uplevel 1 [list info exists __[info level 0]]]} { return }
   uplevel 1 [list set __[info level 0] exists]

   set caller [lindex [info level 1] 0]
   uplevel 1 [list restore $caller $vars]
   catch [list uplevel 1 [info body $caller]] result
   uplevel 1 [list save $caller $vars]
   dict incr -level +2
   return -code return $result
 }

 proc prufa {{si 0}} {
   persist si
   incr si 42
   puts "si = $si"
 }

 prufa
 prufa
 prufa