Sure. Sorry there's no documetation.

http://www.yak.net/strick/crpl.tcl.2000-02-01.txt

(there may be some errors due to lack of esacaping < & > .... maybe you should 'view source' and copy from there)

# crpl.tcl
#
# Routines for minimizing typing in tcl
#
# Author: strick
#
# Date: December, 1999

#
# crpl functions
#

if ![llength [info command common]] {
uplevel #0 {

proc crpl {} { return 2000-01-17 }

set crpl_common ""

proc common args {
	global crpl_common
	set crpl_common $args

	#foreach x $crpl_common { set a($x) 0 }
	#foreach x $args { set a($x) 0 }
	#set crpl_common [lsort [array names a]]
}

rename proc crpl_pre_common_proc

crpl_pre_common_proc proc {name vars body} {
	global crpl_common

	# optimize -- only global if appears
	set z {}
	foreach x $crpl_common {
		if [string match "*$x*" $body] {lappend z $x}
	}

	if [llength $z] {
		crpl_pre_common_proc $name $vars "[concat global $z];;; $body"
	} else {
		crpl_pre_common_proc $name $vars "$body"
	}
}

proc crpl_join {args} { join $args }

proc unk_equals {c args} {

	# short simple case:  var=cmd
	if [regexp -nocase {^([a-z0-9_]+)[=]([^=]*)$} $c 0 1 2] {
		if {$2==""} {
		  proc $c args " 
			upvar 1 [list $1] z
			set z \[join \$args \]
		  "
		} else {
		  set cmd [list [list $2]]
		  proc $c args "
			upvar 1 [list $1] z
			set z \[uplevel 1 $cmd \$args \]
		  "
		}
		return [ uplevel 1 [list $c] $args ]
	}


	# short simple case:  var(sub)=cmd
	if [regexp -nocase {^([a-z0-9_]+)[(]([a-z0-9_]*)[)][=]([^=]*)$} $c 0 1 2 3] {
		if {$3==""} {
		  proc $c args " 
			upvar 1 [list $1] z
			set z($2) \[join \$args \]
		  "
		} else {
		  set cmd [list [list $3]]
		  proc $c args "
			upvar 1 [list $1] z
			set z($2) \[uplevel 1 $cmd \$args \]
		  "
		}
		return [ uplevel 1 [list $c] $args ]
	}


	set v [split $c =]
	set n [llength $v]
	set cmd [lindex $v end]
	set z [uplevel 1 [list $cmd] $args]

	for {set i 0} {$i < $n - 1} {incr i} {
		set w [lindex $v $i]
		
		if {$w == ""} continue

		if {$n == 2} { # simple single var
			set x $z
		} elseif {$i == $n - 2} {
			set x [lrange $z $i end]
		} else {
			set x [lindex $z $i]
		}
		
		if [string match /* $w] {
			set level #0
			#set w [string range $w 1 end]
			regsub {^/} $w {} w
		} else {
			set level 1
		}

		switch -glob -- $w {
			"*+" {set op incr}
			"*|" {set op append}
			"*^" {set op lappend}
			"*@" {set op @}
			default {set op set}
		}

		if {$op != "set"} { # chop off extra char
			regsub {.$} $w {} w
		}

		if {$op != "@"} {
		  if [regexp {^([^()]*)[(](.*)[)]$} $w 0 1 2] {
			upvar $level $1 a
			$op a($2) $x	
		  } else {
			upvar $level $w a
			$op a $x	
		  }
		} else {
			upvar $level ${w}n an
			set an [llength $x]
			for {set j 0} {$j < $an} {incr j} {
				upvar $level ${w}$j a
				set a [lindex $x $j]
			}
		}
	}

	return $z
}

proc eval_parens_expr c {
	regsub -all {[A-Za-z_][A-Za-z0-9_]*} $c {$&} c
	regsub -all {[^<>!=][=](?![=])} $c {&=} c
	regsub -all {@([$][A-Za-z_][A-Za-z0-9_]*)} $c {[llength \1]} c
	regsub -all {#([$][A-Za-z_][A-Za-z0-9_]*)} $c {[string length \1]} c
	regsub -all {'[$]([A-Za-z_][A-Za-z0-9_]*)} $c {"\1"} c

	uplevel 1 [list expr $c]
}
proc () {args} {
	upvar 1 __cond__ m
	if $m {
		return ""
	} else {
		uplevel 1 $args
	}
}
proc unk_parens {c args} {
	if [llength $args] { 
		upvar 1 __cond__ m
		set b [ uplevel 1 [list eval_parens_expr $c] ]
		if { $b==0 || $b=="" } {
			set m 0
			return ""
		} else {
			set m 1
			uplevel 1 $args
		}
	} else {
		uplevel 1 [list eval_parens_expr $c]
	}
}
proc unk_tilde {c args} {
	regexp {[~](.*)} $c 0 f
	set z ""
	catch {set z [uplevel 1 [list $f] $args ]}
	return $z
}
proc unk_bquot {c args} {
	regexp {[`](.*)} $c 0 f
	#puts stderr [join [concat [list <<< $f ] $args]]
	puts stderr [concat [list <<< $f ] $args]
	if [set v [catch {uplevel 1 [list $f] $args} x]] {
		global errorCode errorInfo
		puts stderr ">ERROR>$v> ``$x''"
		error $x $errorInfo $errorCode 
	} else {
		puts stderr ">>> ``$x''"
	}
	return $x
}
proc unk_squot {c args} {
	regexp {['](.*)} $c 0 f
	set z [uplevel 1 [list $f] $args ]
	puts stderr "=== ``$z''"
	return $z
}
proc unk_bang {c args} {
	regexp {[!](.*)} $c 0 f
	set z [uplevel 1 [list $f] $args ]
	expr { $z=="" || $z==0 }
}
proc unk_assert {c args} {
	set z [uplevel 1 $args ]
	if !$z {
		error "ASSERTION FAILED: [expr {$c=="@"? $args: $c}]"
	}
}
proc unk_apos {c args} {
	set c [split $c ']
	uplevel 1 $c $args
}
proc unk_apos {c args} {
	set z {}
	foreach c [split $c '] {
		set s 0
		foreach c [split $c `] {
			if {$s} {
				lappend z [lindex $args end]
				set args [lrange $args 0 [expr {[llength $args]-2}]]
			}
			if { $c!="~"} {lappend z $c}
			set s 1
		}
	}
	uplevel 1 $z $args
}
proc unk_comma {c args} {
	regexp {^([-:\w]+)[,](.*)} $c 0 m f
	set z [uplevel 1 [list $f] $args ]
	uplevel 1 [list $m $z]
}
proc unk_li {c list} { 
	lindex $list $c 
}
proc unk_limi {c list} {
	regsub {.$} $c {} c
	lrange $list $c end
}
proc unk_mili {c list} {
	lindex $list [expr {[llength $list]+$c}]
}
		


proc metacrpl {pat cmd} {
	global metacrpl
	lappend metacrpl $pat $cmd
}
metacrpl {^[0-9]+$} unk_li
metacrpl {^[0-9]+-$} unk_limi
metacrpl {^-[0-9]+$} unk_mili
metacrpl {^[`]} unk_bquot
metacrpl {^[']} unk_squot
metacrpl {^[~]} unk_tilde
metacrpl {^[!]} unk_bang
metacrpl {^[@]} unk_assert
metacrpl {^([-:\w]+)[,](.*)} unk_comma
metacrpl {^[(].*[)]$} unk_parens 
metacrpl {^.*[=].*$} unk_equals 
metacrpl {^.*[`'].*$} unk_apos 


rename unknown crpl_pre_unknown
proc unknown {c args} {
	if {$c=="" || $c==":"} {
		join $args
	} else {
		global metacrpl
		set f crpl_pre_unknown
		foreach {p u} $metacrpl {
			if [regexp $p $c] { set f $u ; break }
		}
		uplevel 1 [list $f $c] $args
	}
}

#++ Aliases for rsi:
proc eq { a b } {
	expr { ![ string compare $a $b ] }
}	

proc ne { a b } {
	string compare $a $b
}	

proc zm { a b } {
	string match $a $b
}	

proc zl { a } {
	string length $a 
}	

proc l args { return $args }

proc ll { a } {
	llength $a 
}	

#-- b'th item of list a:
proc li { a b } {
	lindex $a $b
}	
proc zi { a b } {
	string index $a $b
}	

#-- Everything from b through c in list a:
proc lr { a b c } {
	lrange $a $b $c
}	
proc zr { a b c } {
	string range $a $b $c
}	

#-- Get the 0'th, first, 2nd item of list:
##	
##	proc 0  x {
##		lindex $x 0
##	}	
##	
##	proc 1  x {
##		lindex $x 1
##	}	
##	
##	proc 2  x {
##		lindex $x 2
##	}	
##	proc -1  x {
##		lindex $x end
##	}	
##	
##	#-- Get everything but the first:
##	proc 1-  x {
##		lrange $x 1 end
##	}	
##	
#-- Initialize variables to: 
#-- ('uplevel' - does it in scope of caller.)
#-- [n]ull string:
proc n args  {
	foreach x $args {
		uplevel 1 [ list set $x {} ]
	}
}	

#-- [z]ero string:
proc z args  {
	foreach x $args {
		uplevel 1 [ list set $x 0 ]
	}
}	

#-- [e]mpty hash (tcl calls it an array):
proc e args  {
	foreach x $args {
		catch { uplevel 1 [ list unset $x ] }
		uplevel 1 [ list set 	"[ get x ](0)" 0 ]
		uplevel 1 [ list unset "[ get x ](0)" ]
	}
}	

#-- more useful version of foreach:
#-- (sort of like perl map - really like lisp mapcar.)
# - v = vector (list of items) - cmd - command to execute on each.
#-- Returns a list of all the results.
proc map { v cmd } {
	set z {}
	foreach x $v {
		lappend z [ uplevel 1 $cmd [ list $x ] ]
	}
	return $z
}	

#-- Adding/multiplying/ANDing/whatever a list of numbers:
#-- zero = 0 ; op = +
proc reduce_dyadic { zero op list } {
	set z $zero
	foreach x $list {
		set z [ expr "\$z $op \$x" ]
	}
	return $z
}
#++ END carpal section.

# p {name args} - defines proc "name" with arguments "args"
#	(the last argument is the body of the procedure)
#
# Beginning an argument with certain characters causes special behavior:
#	^ promotes to the variable to the caller's scope
#	/ refers to the global variable by that name

proc p {name args} {
	n vars pre

	n=ll $args

	foreach x [lr $args 0 [(n-2)]] {
		switch -glob -- $x {
			^* {
				v=zr $x 1 end
				vars^= __name__$v
				pre|= " upvar 1 \$__name__$v $v ;;"
			}

			/* {
				v=zr $x 1 end
				pre|= "[list global $v];;"
			}

			* {
				vars^= $x
			}
		}
	}

	body=li $args end
	proc $name $vars $pre$body
}

proc pe args { 
	puts stderr "=== $args"
	return $args
}

proc ce args { # catch exception
	set z ""
	catch { set z [ uplevel 1 $args ] }
	return $z
}
proc i0 n { z=
	for {set i 0} {$i<$n} {incr i} {lappend z $i}
	return $z
}
proc io n { z=
	for {set i 1} {$i<=$n} {incr i} {lappend z $i}
	return $z
}

proc do args {
	puts stderr "<<< $args"
	if [set v [catch {uplevel 1 $args} x]] {
		global errorCode errorInfo
		puts stderr ">ERROR>$v> $x"
		error $x $errorInfo $errorCode 
	} else {
		puts stderr ">>> $x"
	}
	return $x
}
proc try {x y {z #}} {upvar 1 _ _
	set t [catch {uplevel 1 $x} _]
	
	### case 1 is not quite right -- need another catch!
	switch $t {
	0	{uplevel 1 $z; return $_}
	1	{uplevel 1 $z; uplevel 1 $y}
	2	{uplevel 1 $z; uplevel 1 {return $_}}
	3	{error BREAK-IN-TRY; break}
	4	{error CONTINUE-IN-TRY; continue}
	default	{error "try default"}
	}
}

}
}

crpl

#TESTS

if {$argv0 == "crpl.tcl"} {
do crpl
do crpl

do puts [(3+4)]

do a=b=c=z=list 1 2 3 4 5 6
do !ll $z
do !ll {}
do !list
do !list a b c
do !!list
do !!list a b c
do ll,list 
do ll,list a b c
do zl,list 
do zl,list a b c
do ll,zl,list a b c
do zl,zl,list a b c
do !ll,list a b c
do puts [(b*10)]
do puts [((a+b)*c)]
do a+=b^=c|==list 10 20 30 40 50
do puts [list $a $b $c $z]
do a@=list 11 12 13
foreach i [lsort,info var ] {
	if [zm err* $i] break
	puts "$i : [~($i)]"
	~parray $i
}


`w(1)=w(2)=w(3)=w(r,!x@,9)=list a b c d e f
`array get w 
`unset w
`w(1)=w(2)=w(3)=w(r,!x@,9)= "a b"
`array get w 
`unset w
`w(1)=w(2)=w(3)=w(r,!x@,9)=
`array get w 
ce `@ expr 0!=1
ce `@test expr 0!=1
ce `@ expr 0==1
ce `@test expr 0==1
`'`ce list a b c
~`continue
ce `break
ce `continue
ce `return 6
`try {a(x)= y} (8)
ce `foreach x [io 9] { try { if {$x==5} break ; pe $x } error }
`p c { try {return 5} {error} ; return 9}
`c
`x=do a=b=c=d=e==list 10 20 30 40 50
`(a)
`(c)
`(x)
`ll,(x)
`0,(x)
`0,0,(x)
`1,(x)
`-1,(x)
`1-,(x)
`1-,1-,(x)
`1-,1-,1-,(x)
`0,1-,1-,1-,(x)
~do error bogus
do (errorCode)
~do break
do (errorCode)
~do continue
do (errorCode)
~do return
do (errorCode)
~do return 3.14
do (errorCode)
do (a+b+c+@x+#x)
do z=pid
do z= pid
do z= pid 1 2 3 4
do z= pid {1 2} {3 4}
do z=
do z=!
do z=~!
```'do ce list a b c
`~`continue
`string'length xyz
`string'match'x* xyz
`string'match`xyz x*

`map {x* y* *y* z *z *} `string'match`xyz
`map {x* y* *y* z *z *} "`string'match`~ xyz"

`y= ok
`(c) (@x)
`(!c) (@x)
`(c-b-a) (@x)
`(!(c-b-a)) (@x)
`(c-b-a) (#x)
`(!(c-b-a)) (#x)
`(@x) ~error bogus
`~(@x) error bogus
`(y=='ok) (@x)
`() : not
`(y='ok) (@x)
`() : not
`(y!='ok) (@x)
`() : not

do common color size
proc a {} { set color red }
proc b {} { puts $color }
`a
`b
`p c { try {return 5} {error} ; return 9}
`c
`p d /y ^n a b { ` $y $n ; y^= $a ; n^= $b ; ` $y $n ; }
`p f /y ^n a b { l $a $b $n $y }
`info arg d
`info arg f
`info body d
`info body f
` $x
`d x lemon lime
`f x fruit veg
`f y fruit veg
'lsort,info command
'map [lsort,info command *=*] info'body
}