Artifact 737848c9f12ae1858e8ecc56bee44f62b9290a52:

• Executable file packages/ns/lib/ns.tcl — part of check-in [6f28308d9b] at 2021-11-16 16:10:52 on branch trunk — bits [encode]

  check that each input is a byte sequence

  eval

  new procedures

  callater

  evallater

  {math rand}

  new procedure

  randprint_256_bitcoin

  ns

  ascall

  do nothing gracefully

  ns

  object

  new procedure

  .rmproc

  proc

  remove extra alias handling

  string

  new procedures

  is bytes

  (user: pooryorick size: 35427)

#! /bin/env tclsh

package require {ycl ns absolute}
package require {ycl ns join}

package require {ycl proc}
[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases

aliases {
	{ycl eval} {
		untraced
	}
	{ycl proc} {
		optswitch
	}
}


namespace eval [join {} tcl mathop] {
	namespace export *
}

alias [join {} tcl mathop !=]

alias variable_ [join {} variable]
#in version 1.8.3, filter evaluates cmdprefix in the scope of its caller
package require [join struct list] 1.8.3
#namespace eval [join {} struct list] {
#	namespace export Lfilter
#}
#namespace import [join {} struct list Lfilter]
#catch {rename lfilter {}}
#rename Lfilter lfilter
aliases {
	{ycl proc} {
		import
		checkargs
		checkspec
		dupproc copy
		formals
		stub
		upmethod
		stub
	}
	{ycl eval} {
		upcall
	}
	{ycl list} {
		add
		lappend
		lappend*
		lindex
		lreplace
		lmap
		lrange
		subset
		take
	}
	{ycl ns normalize} {
	}
	{ycl string} {
		ssplit split
		regsplit
	}
	{ycl var} {
		$
	}
}

alias info_ [join {} info]
alias lmap_ [join {} lmap]
alias lappend_ [join {} lappend]
alias lindex_ [join {} lindex]
alias namespace [join {} namespace]


namespace eval doc {}

variable UNIQUE_IN {} 


# define [which] early in order to use it below 
package require {ycl ns which}


variable [join doc variable] {
	description {
		like the built-in [variable]
			but the name is a ycl variable name
	}
	definitions {
		{ycl name} {
			a list
				where 
					the first item
						is a list whose items are incorporated into the
						containing list

						an empty list signifies the global namespace

							making the name absolute

					remaining items before the last item

						names of namespaces leading to the resource

					the last item

						the name the resource
		}
	}
}
proc variable args {
	optswitch [expr {[llength $args] == 0}] {
		0 {
			lassign $args name
		}
	}
	lreplace args 0 0 [join {*}$name[set name {}]]
	upcall 1 variable_ {*}$args
	return
}



proc allocate args {
	lassign $args prefix suffix
	set ns [upcall current] 
	while 1 {
		set new [join $ns $prefix][incr cmdcount]$suffix
		if {![namespace exists $new]} {
			return [nscall $new current]
		}
	}
}


variable {doc call} {
	description
		$returns a command to resolve $args as a command relative to $ns.
}
proc call {ns args} {
	variable tailcall
	tailcall apply [list args $tailcall $ns] {*}$args
}


variable {doc cleanly} {
	description
		clone a namespace

		evaluate $script in the clone

		delete the clone

		return the result of the evaluation
}
proc cleanly script {
	variable cleanly
	set upns [upcall 1 current]
	set parent [namespace qualifiers $upns]
	while 1 {
		set tmpns [join ${parent} [info_ cmdcount]~temp]
		if {![namespace exists $tmpns]} break
	}
	duplicate $upns $tmpns
	catch [list upcall 1 apply [
		list script $cleanly $tmpns] $script] cres copts
	namespace delete $tmpns
	return -options $copts $cres
}


variable {doc current} {
	description {
		like [namespace current]
			but the name of the global namespace is the empty string
	}
}
proc current {} {
	set ns [upcall 1 namespace current]
	if {$ns eq [globalns]} {
		set ns {}
	}
	return $ns
}


try [string map [
	list @apply@ [list [join {} apply]
	] @error@ [list [join {} error]
	] @if@ [list [join {} if]
	] @list@ [list [join {} list]
	] @namespace@ [list [join {} namespace]
	] @set@ [list [join {} set]
	] @tailcall@ [list [join {} tailcall]]
] {



proc methoddispatch {ns prefix args1 _ args} {
	tailcall apply [list {_ prefix args1 args2} {
		@tailcall@ {*}$prefix $_ {*}$args1 {*}$args2
	} $ns] $_ $prefix $args1 $args
}


proc dispatchroutine {ns prefix _ args} {
	tailcall @apply@ [list {prefix args} {
		@tailcall@ {*}$prefix {*}$args
	} $ns] $prefix {*}$args
}



}]


variable {doc disposal} {
	description {
		Arrange for a namespace to be deleted when one of its namespace
		ensemble commands is deleted .
		Register a teardown method for an object.  The teardown method is
		called just prior to the deletion of the object.
		
		"object" means an ensemble commmand where the name of the object
		command name itself is automatically inserted as the first argument.
	}
}
proc disposal {objname ns args} {
	if {[llength $args]} {
		set trace [list [join {} apply] [list {cmd oldname newname ops} {
			#this catch is a hack
			#todo: fix trace so that trace errors don't disappear 
			if {[catch {
				{*}$cmd $oldname $newname $ops
				#the namespace may already be deleted, causing this command to be
				#deleted
				catch {namespace delete $oldname}
				if {[namespace which $oldname] ne {}} {
					rename $oldname {}
				}
			} eres eopts]} {
				puts stderr [dict get $eopts -errorinfo]
				puts stderr [dict get $eopts -errorstack]
				#this currently gets swallowed by Tcl trace machinery
				return -options $eopts $eres
			}
		} $ns] {*}$args]
		trace add command $objname delete $trace
	}
	return $trace
}


stub dupcmds {from to args} {
	package require {ycl ns ensemble}
} {
	if {[llength $args] == 0} {
		set filter [list apply {{name type} {return 1}}]
	} elseif {[llength $args] == 1} {
		lassign $args filter
	} else {
		error [list {wrong # args}]
	}
	if {![absolute? $from]} {
		set from [uplevel 1 [list namespace which -command $from]]
	}
	if {![absolute? $to]} {
		set to [normalize $to [uplevel {namespace current}]]
	}
	set procs [info_ procs [join $from *]]
	foreach proc $procs {
		if {![{*}$filter $proc proc]} continue
		set toproc [join $to [namespace tail $proc]]
		if {[set origin [namespace origin $proc]] ne $proc} {
			#imported command. import it
			import $toproc $origin
		} else {
			dupproc $proc $toproc 
		}
	}
	foreach cmd [info_ commands [join $from *]] {
		if {![{*}$filter $cmd command]} continue
		if {$cmd in $procs} continue
		set tocmd [join $to [namespace tail $cmd]]
		if {[namespace ensemble exists $cmd]} {
			set cmdns [namespace ensemble configure $cmd -namespace]

			#only duplicate an ensemble namespace if it is a child of $from
			if {[string range $cmdns 0 [
				expr {[string length $from]-1}]] eq $from} {
				set tocmdns $to[
					string range $cmdns [string length $from] end] 
				if {![namespace exists $tocmdns]} {
					duplicate $cmdns $tocmdns
				}
			} else {
				set tocmdns $cmdns
			}
			set origin [namespace origin $cmd]
			if {$origin eq $cmd} {
				ensemble duplicate $cmd $tocmd tons $tocmdns
			} elseif {$origin eq $tocmd} {
				error [list {new routine is the same as its origin}]
			} {
				import $tocmd $origin
			}
		} else {
			#alias other non-procedure commands. It's the best we can do.
			import $tocmd [namespace origin $cmd]
			lappend_ copied $cmd
		}
	}
	return
}

variable {doc duplicate} {
	description {
		duplicate a namespace
	}
	args {
		from {
			description {
				positional

				the namespace to duplicate
			}
		}
		to {
			description {
				positional
				the namespace that will become a duplicate of $from
			}
		}
		base {
			description {
				used internally during recursive calls to duplicate
			}
			default {
				lindex_ $to
			}
		}
		prune {
			description {
				A command that receives one argument, the name of a namespace
				within $from, and returns true or false, indicating whether or
				not to prune (skip for duplication purposes) the namespace.
			}
			default {
				lindex_ [join [namespace current] prune]
			}
		}
		vars {
			description {
				A list of variables to copy. If the list is empty, no variables
				are copied.  By default, all variables are copied.
			}
			default {}
		}
		cmd_filter {
			description {
				A command prefix to which the source name and type will be
				appended, and which returns true if the name is excepted an
				false otherwise
			}
			default {}
		}
	}
}
proc duplicate {from to args} {
	checkargs [set [join doc duplicate]] {*}$args
	if {![absolute? $from]} {
		set from [normalize $from [uplevel {namespace current}]]
	}
	if {![absolute? $to] != 0} {
		set to [normalize $to [uplevel {namespace current}]]
	}
	namespace eval $to {}
	set fromlen [string length $from]

	#duplicate children before duplicating commands so that any
	#namespaces needed by ensembles already exist
	#This de-laces namespace and ensemble creation
	foreach child [namespace children $from] {
		if {[string first $base $from] >= 0} {
			#don't copy self into self
			continue
		}
		set relchild [string range $child $fromlen end]
		if {$child eq $to} {
			continue
		}
		if {[$prune $child]} {
			continue
		}
		duplicate $child $to$relchild base $base
	}

	set dupvars [list dupvars $from $to]
	if {[info_ exists vars]} {
		lappend_ dupvars $vars
	}
	{*}$dupvars

	set dupcmds [list dupcmds $from $to]
	if {[info_ exists cmd_filter]} {
		lappend_ dupcmds $cmd_filter
	}
	{*}$dupcmds

	#could use -clear, but choose instead to keep whatever is there.
	#Caveat Emptor.
	namespace eval $to [list namespace export {*}[
		namespace eval $to {namespace export}] {*}[
			namespace eval $from {namespace export}]]
	namespace eval $to [list namespace path [
		list {*}[namespace eval $to {namespace path}] {*}[
			namespace eval $from {namespace path}]]]
	namespace eval $to [list namespace unknown [
		namespace eval $from {namespace unknown}]]

	return $to
}


#copy all procs from namespace $from to namespace $to
proc dupprocs {from to} {
	foreach proc [info_ proc [join $from *]] {
		dupproc $proc [join $to [namespace tail $proc]]
	}
}


variable {doc dupvars} {
	description {
		Duplicate variables from one namespace to another.
	}
	args {
		from {
			description {
				The namespace to copy from.
			}
			positional true
		}
		to {
			description {
				The namespace to copy to.
			}
			positional true
		}
		names {
			description {
				A list of relative variable names in from to copy.
			}
			positional true
			optional true
		}
	}

}
proc dupvars {from to args} {
	if {[llength $args] == 0} {
		set names [info_ vars [join $from *]]
	} elseif {[llength $args] == 1} {
		lassign $args names
	} else {
		error [list {wrong # args}]
	}
	if {![absolute? $from]} {
		set from [normalize $from [uplevel {namespace current}]]
	}
	if {[absolute? $to]} {
		set to [normalize $to [uplevel {namespace current}]]
	}
	foreach name $names {
		if {[absolute? $name]} {
			set fullfrom $name
		} else {
			set fullfrom [join $from $name]
		}
		set fullto [join $to [namespace tail $name]]
		if {![catch [list upvar 0 $fullfrom $fullfrom]]} {
			#Variable was created by upvar. Continue the tradition.
			upvar 0 $fullfrom $fullto
			continue
		}
		if {[namespace which -variable $fullfrom] ne {}} {
			if {[info_ exists $fullfrom]} {
				if {[array exists $fullfrom]} {
					array set $fullto [array get $fullfrom]
				} else {
					set $fullto [set $fullfrom]
				}
			} else {
				#var is declared but not defined
				variable $name
			}
		}
	}
}


proc eval args {
	variable eval_
	switch [llength $args] {
		0 - 1 {
			#raise the error
			tailcall namespace eval
		}
		2 {
			tailcall namespace eval {*}$args
		}
		default {
			take args namespace
			tailcall namespace eval $namespace [list $eval_ {*}$args]
		}
	}
}


variable {doc gwich} {
	description {
		like [which]
			but resolves each name relative to the global namespace 
	}
}
proc gwhich args {
	namespace eval [globalns] [list [namespace which which] {*}$args]
}


namespace ensemble create -command info -map {
	vars info_vars
}


variable {doc info_vars} {
	description {
		like [info vars], but does not include names of variables in the
		global script, and only returns the simple name.
	}
}
proc info_vars {} {
	set ns [uplevel 1 {namespace current}]
	set nsdelim [join $ns {}]
	lmap_  varname [info_ vars [join $ns *]] {
		if {[string first $nsdelim $varname] >= 0} {
			namespace tail $varname
		} else {
			continue
		}
	}
}


proc isglobal args {
	set ns [uplevel 1 {namespace current}]
	expr {$ns eq [globalns]}
}


variable {doc move} {
}
proc move {old new} {
	variable nscontents
	set new [upcall 1 namespace eval $new {namespace current}]
	lassign [upcall 1 namespace eval $old $nscontents] children commands vars
	foreach var $vars {
		variable [join $new [namespace tail $var]] [set $var]
	}
	set ensembles {}
	foreach command $commands {
		set status [catch [
			list namespace ensemble configure $command] cres copts]
		if {$status} {
			rename $command [join $new [namespace tail $command]]
		} else {
			set newname [join $new [namespace tail $command]]
			dict set cres -namespace $newname
			lappend_ ensembles $command  $cres 
		}
	}
	foreach child $children {
		set newchild [join $new [namespace tail $child]]
		if {![namespace exists $newchild]} {
			move $child $newchild
		}
	}
	foreach {command config} $ensembles {
		dict set config -command [join $new [namespace tail $command]]
		set namespace [dict get $config -namespace]
		if {[string first [join $new {}] $namespace] < 0} {
			set ensns [join [namespace current] [info cmdcount]_ns]
			move $namespace $ensns 
			dict set config -namespace $ensns
		}
		dict unset config -map
		dict unset config -subcommands
		dict unset config -namespace
		namespace eval $namespace [
			list namespace ensemble create {*}$config]
	}
	nscall $new namespace path [
		upcall 1 namespace eval $old {namespace path}]
	set exports [upcall 1 namespace eval $old {namespace export}]
	namespace eval $new [list namespace export -clear $exports]
	uplevel 1 [list namespace delete $old]
	return $new
}


variable {doc new} {
	description {
		create a new namespace
	}
	args {
		of {
			description {
				what to create a new instance of
			}
			process {
				upcall 1 [join [namespace current] normalize] $of
			}

		}
		name {
			description {
				optional

				name of the new namespace
			}
			process {
				upcall 1 [join [namespace current] normalize] $name
			}
			default {
				set upns [uplevel {namespace current}]
				while {[info exists [join $upns [incr name]]]} {}
				lindex_ [join $upns $name]
			}
		}
		prune {
			description {
				optional

				name of a procedure that specifies whether to prune a namespace
				when duplicating
			}
			process {
				lappend_ dupargs prune $prune
			}
			default {}
		}
	}
}
proc new args {
	set dupargs {}
	checkargs [$ doc new] {*}$args
	ensemble duplicate $of $name {*}$dupargs
}


variable {doc nscall} {
	description {
		like tailcall
			resolve the name of the routine in the namespace of the caller
		like uplevel
			call the command the given namespace
	}
}
proc nscall {ns args} {
	set name $args
	lindex name 0
	set resolved [upcall 1 which $name]
	lreplace args 0 0 $resolved
	upcall 1 namespace eval $ns $args 
}


variable {doc nseval} {
	description {
		sugar

		the following commands are equivalent

			nseval $namespace [list $one $two $three]

			nseval $namespace $one $two $three

	}
}
proc nseval {namespace args} {
	tailcall namespace eval $namespace $args
}


variable {doc object} {
	description
		create
			a command
				the new object
			a new namespace
				to store variables of the new object
		make commands
			in
				$ns
					first argument
						name of the command for the new object
			available as actions of the new command

		give an object new behaviours by adding the name of a namespace
		containing those behaviours to the path of the object

		deletion of the object is not a behaviour of the object but the
		behaviour of the owner of the object


		the namespace of the object
			is for
				storing variables and other state

				resolving routines from

			is not for routines

				a routine located directly in the namespace of the object

					can not be overridden

					interferes with routines such as [.routine]
}


proc object args {
	package require {ycl string printable}
	aliases {
		{ycl string} {
			printable
		}
	}
	proc object args {
		variable apply
		if {[llength $args]} {
			set args [lassign $args[set args {}] name]
			set name [upcall 1 normalize $name[set name {}]]
			if {[llength $args]} {
				lassign $args objns
			} else {
				set objns $name
			}
		} else {
			set objns [join [namespace current] objects [info_ cmdcount]]
		} 

		if {![info_ exists name]} {
			set name $objns
		}

		if {[namespace which $name] ne {}} {
			rename $name {}
		}
		if {[namespace exists $objns]} {
			namespace delete $objns
		}

		set routines [info_ commands object::*]
		lmap routine routines {
			namespace tail $routine
		}

		if 0 {
			the new object is entirely contained in $objns
				which consists of the following

					resolver namespace

						the namespace object commands are resolved in

					object

						the namespace ensemble procedure that acts as the
						dispatcher for the object

					state

						a namespace where information about the state of the
						object itself is stored

					self

						the imported public procedure for the object

						used along with [namespace origin] to determine the
						name of the public procedure 


				it might also make sense to have one namespace for resolving
				functions related to the adminitration of the object
					and to reserve the "state" namespace exclusively for things
					related to the thing the program models 
		}

		set resolverns [join $objns state]

		nscall $resolverns namespace path [list [
			join [namespace current] object] {*}[
			namespace eval $resolverns {namespace path}]]

		# create an ensemble that transforms the first argument into the name
		# of the object and the second argument into the routine for the object

		set object [namespace eval $resolverns [
			list namespace ensemble create -command [
				join $objns object] -prefixes 0 \
				-subcommands $routines -parameters _  -unknown [which objunknown]
		]]

		set self [join $objns self]
		alias $name $object $self
		# self is an import so that [origin] finds the current name of the
		# object
		import $self $name

		trace add command $object delete [list apply [list {_ ns oldname newname op} {
			catch {
				set name [$_ .name]
			} cres
			set adminns [$_ .adminns]
			namespace upvar $adminns dispose dispose
			# any disposal routine must run before $name is deleted or there will
			# be an error to the extend that the routine no longer exists
			if {[info_ exists dispose]} {
				set status [catch {
					{*}$dispose $name {} delete
				} cres copts]
				if {$status == 1} {
					puts stderr [list {ns object disposal failed}]
					puts stderr [list [printable [
						dict get $copts -errorinfo] ascii 0 tcl 0]]
				}
			}

			rename $name {}
			namespace delete $ns
		} [namespace current]] $self $objns]


		# {to do}
		#     move this trace to $self so that the client doesn't mess with it?
		trace add command $name delete [list apply [list {object oldname newname op} {
			if {[namespace which $object] ne {}} {
				rename $object {}
			}
		}] $object]


		return $name
	}
	tailcall object {*}$args
}


proc objroutine {routine _ args} {
	tailcall $_ .call {*}$routine {*}$args
}



proc objunknown {_ self routine args} {
	variable objwrapped
	set ns [namespace ensemble configure $_ -namespace]
	set routines [namespace ensemble configure $_ -subcommands]
	set path [nscall $ns namespace path]
	foreach item $path {
		set routines1 [info_ commands ${item}::*]
		lmap item routines1 {
			namespace tail $item
		}
		add routines {*}$routines1 
	}
	namespace ensemble configure $_ -subcommands $routines
	if {$routine ni $routines} {
		set adminns [namespace parent $ns]
		namespace upvar $adminns unknown unknown wrapped wrapped
		if {[info_ exists wrapped]} {
			return [list $objwrapped $routine]
		} elseif {[info_ exists unknown]} {
			return [list {*}$unknown $routine]
		}
	}
	return
}


proc objwrapped {routine _ args} {
	namespace upvar [$_ .adminns] wrapped wrapped
	tailcall {*}$wrapped $routine {*}$args
}


namespace eval object {
	namespace eval system {
		namespace export *
		namespace path [list [namespace parent [namespace parent]]]

		set objroutine [join [namespace parent [namespace parent]] objroutine]

		namespace eval doc {}
		variable {doc call} {
			description {
				evaluate a command in the namespace of the object
			}
		}

		aliases {
			{ycl list} {
				add
			}
		}


		proc $ {_ name} {
			$_ .vars [list $name var]
			if {![info_ exists var]} {
				error [list {no such variable} $name]
			}
			return $var
		}


		proc .allocate _ {
			set adminns [$_ .adminns]
			namespace upvar [$_ .adminns] counter counter
			incr counter
			return [join $adminns aux $counter]
		}


		proc $.exists {_ name} {
			$_ .vars [list $name var]
			info_ exists var
		}


		proc = {_ name value} {
			$_ .vars [list $name var]
			set var $value
			return $var
		}


		variable {doc act} {
			description {
				like .apply

					but the name of the object is automatically inserted as the
					first argument
			}
		}
		proc .act {_ args} {
			take args spec script
			tailcall apply [list $spec $script [$_ .namespace]] $_ {*}$args
		}


		proc .adminns {_ args} {
			set parent [namespace qualifiers $_]
			return $parent
		}


		proc .apply {_ args} {
			take args spec script
			tailcall apply [list $spec $script [$_ .namespace]] {*}$args
		}


		try [string map [
			list @join@ [list [which join]]
		] {
			proc .attribute {_ name} [string map [
				list @apply@ [list [join {} apply]]
			] {
				set ns [@join@ [$_ .namespace] . attribute]
				interp alias {} [@join@ $ns $name] {} [
					namespace which .forward] [list .doattribute $name]
				if {$ns ni [$_ .nscall namespace path]} {
					$_ .extend $ns
				}
				return
			}] 
		}]


		proc .disposal {_ args} {
			set adminns [$_ .adminns]
			set object [$_ .object]
			namespace upvar $adminns dispose dispose disposens disposens
			if {[llength $args]} {
				lassign $args name
				if {[absolute? $name]} {
					set dispose $args
				} else {
					set args [upcall 1 namespace code $args]
					set disposens [upcall 1 namespace current] 
					set dispose $args
				}
			}
			if {[info_ exists dispose]} {
				if {[info_ exists disposens]} {
					set cmd $dispose
					lindex cmd 3
					return [list $disposens $cmd]
				} else {
					return [list [namespace qualifiers $dispose] $dispose]
				}
			}
		}


		proc .forward {target _ args} {
			tailcall $_ {*}$target {*}$args
		}


		proc .doattribute {_ name args} {
			$_ .vars [list $name var]
			if {[llength $args]} {
				set var $args
				lindex var 0
			}
			return $var
		}


		variable {doc call} {
			description {
				resolve the routine relative to the namespace of $_ and call it
				from the caller.
			}
		}
		proc .call {_ args} {
			tailcall apply [list args {
				tailcall {*}$args
			} [$_ .namespace]] {*}$args[set args {}]
		}


		proc .eject {_ name} {
			if {![absolute? $name]} {
				set name [upcall 1 normalize $name[set name {}]] 
			}
			set path [$_ .upcall namespace path]
			set idx [lsearch -exact $path $name]
			if {$idx < 0} {
				error [list {not found} $name]
			}
			lreplace path $idx $idx
			$_ .upcall namespace path $path
			return
		}


		variable {doc eval} {
			description {
				concate arguments into a script an evaluate the script in the
				namespace of the object
			}
		}
		proc .eval {_ args} {
			tailcall namespace eval [$_ .namespace] {*}$args
		}


		variable {doc extend} {
			description {
				adds a namespace to the path of object  

				for [.next] to work properly

					routines in the namespace must not be aliases

					can be imported with [namespace import]
			}
		}
		proc .extend {_ what} {
			if {![absolute? $what]} {
				set what [upcall 1 normalize $what]
			}
			if {![namespace exists $what]} {
				error [list {no such namespace} $what]
			}
			set path [$_ .upcall namespace path]
			set idx [lsearch -exact $path $what]
			if {$idx == 0} return
			if {$idx > 0} {
				lreplace path $idx $idx 
			}
			if {$what ni $path} {
				set path [linsert $path[set path {}] 0 $what]
			}
			$_ .upcall namespace path $path
			set routines [info_ commands ${what}::*]
			lmap routine routines {
				namespace tail $routine
			}
			$_ .methods {*}$routines
			return $path
		}


		proc .filter {_ type op args} {
			optswitch $type {
				object {
					optswitch $op {
						call {
							set adminns [$_ .adminns]
							set oldname ${adminns}::oldname
							if {[namespace which $oldname] ne {}} {
								$_ .unfilter
							}
							set name [$_ .name]
							set self [$_ .self]
							set alias [interp alias {} $name]
							set object [::lindex $alias 0]

							set cmdtraces [trace info command $name] 
							set exectraces [trace info execution $name]
							untraced $name {
								rename $name $oldname
								set oldself ${adminns}::oldself
								rename $self $oldself
								interp alias {} $name {} {*}$args $object $self
								import $self $name
							}
						}
					}
				}
			}
		}


		proc .insert {_ name} {
			if {![absolute? $name]} {
				set name [$_ .upcall normalize $name] 
			}
			set path [$_ .upcall namespace path]
			$_ .upcall namespace path [list $name {*}$path]
			return
		}


		if 0 {
			can these be deleted yet?

			proc .method {_ name args} {
				tailcall $_ .makemethod [which methoddispatch] [
					$_ .namespace] $name {*}$args
			}


			proc .makemethod {_ dispatch ns name args} {
				set prefix [lassign $name[set name {}] name]
				if {![llength $args] && ![llength $prefix]} {
					lappend args name
					set name [namespace tail $name]
				}
				if {![llength $prefix]} {
					set prefix $args[set args {}]
				}

				set alias [join $ns $name]
				set routine $prefix
				lindex routine 0
				set routinens [namespace qualifiers $routine]
				set routinename [namespace tail $routine]
				if {
					$routinename eq $name
					&&
					(
						$routinens eq {}
						||
						$routinens eq $ns
					)
				} {
					error [list {alias would refer to itself} \
						alias $alias target $routine]
				}
				interp alias {} $alias {} $dispatch $ns $prefix $args
				return
			}

		}


		variable {doc .invoke} {
			description {
				call a method of $_ from the namespace of $_
			}
		}
		proc .invoke {_ name args} {
			$_ .eval [list $_ $name {*}$args]
		}


		proc .method {_ args} {
			$_ .methods {*}$args
		}


		proc .methods {_ args} {
			set object [$_ .object]
			set commands [namespace ensemble configure $object -subcommands]
			if {[llength $args]} {
				add commands {*}$args
			}
			namespace ensemble configure $object -subcommands $commands
			return $commands
		}


		proc .name _ {
			set self [$_ .self]
			namespace origin [$_ .self]
		}


		proc .namespace _ {
			set object [$_ .object]
			namespace ensemble configure [namespace origin $object] -namespace
		}


		variable {doc .next} {
			description {
				looks up a method in later namespace than the current one 
			}
		}

		variable {doc next} {
			description {
				returns full name of the routine named $routine in the
				namespace path of the calling namespace

				bypassing any routine whose origin is in the calling namespace
			}
		}
		try [string map [list @info@ [list [join {} info]]] {
			proc .next {_ routine} {
				set path [$_ .nscall namespace path]
				set currentns [upcall 1 namespace current]
				set idx [lsearch -exact $path $currentns]
				set newpath $path
				lrange newpath $idx+1 end
				while 1 {
					namespace eval .switch [list namespace path $newpath]
					set found [namespace eval .switch [
						list ::namespace which $routine]]
					if {$found eq {}} break
					set origin [namespace origin $found]
					set originns [namespace qualifiers $origin]
					if {$originns eq $currentns} {
						set foundns [namespace qualifiers $found]
						set idx [lsearch -exact $path $foundns]
						if {$idx < 0} break
						incr idx
						set newpath $path
						lrange newpath $idx end
					} else {
						break
					}
				}
				return $found
			}
		}]


		variable {doc .nscall} {
			description {
				call $args as a prepared command in the namespace of the object

				no substitutions are performed

				the following are equivalent

					$_ .nscall one two three

					namesapce eval [$_ .namespace] one two three
			}
		}
		proc .nscall {_ args} {
			tailcall namespace eval [$_ .namespace] $args
		}


		variable {doc .nsdo} {
			description {
				call a method of the object from the namespace of the object 
			}
		}
		proc .nsdo {_ args} {
			tailcall $_ .eval [list $_ {*}$args]
		}


		proc .nsgen _ {
			while 1 {
				set ns [join [$_ .namespace] [info_ cmdcount]]
				if {![namespace exists $ns]} {
					return [namespace eval $ns {namespace current}]
				}
			}
		}


		proc .object _ {
			namespace eval [namespace qualifiers $_] {
				namespace which object
			}
		}


		proc .rmproc {_ name} {
			set object [$_ .object]
			set map [namespace ensemble configure $object -map]
			if {[dict exists $map $name]} {
				dict unset map $name
				namespace ensemble configure $object -map $map
			} else {
				error [list {no such routine registered} $name]
			}
			return
		}


		proc .routine {_ name args} {
			variable objroutine
			if {![llength $args]} {
				lappend_ args $name
				set name [namespace tail $name[set name {}]]
			}

			set object [$_ .object]
			set map [namespace ensemble configure $object -map]
			set cmd [list $objroutine $args]
			dict set map $name $cmd 
			namespace ensemble configure $object -map $map
			$_ .method $name
			return 
		}


		try [string map [list \
			@info@ [list [join {} info]] 
		] {
			proc .routines _ {
				set res {}
				foreach ns [list [$_ .namespace] {*}[$_ .nscall namespace path]] {
					foreach name [nscall $ns @info@ commands] {
						set name [nscall $ns namespace which $name[set name {}]]
						set parent [namespace qualifiers $name] 
						if {$parent eq $ns} {
							set tail [namespace tail $name]
							if {$tail ni $res} {
								lappend res tail
							}
						}
					}
				}
				lsort -dictionary $res
			}
		}]


		proc .self _ {
			join [namespace parent [$_ .namespace]] self
		}


		proc .unfilter {_ type op args} {
			optswitch $type {
				object {
					optswitch $op {
						call {
							set adminns [$_ .adminns]
							set oldname ${adminns}::oldname
							if {[namespace which $oldname] eq {}} {
								error [list {no filter}]
							}
							set self [$_ .self]
							set name [$_ .name]

							set oldself ${adminns}::oldself
							rename $self {}
							rename $oldself $self

							untraced $name {
								# now the user routine can be removed without
								# triggering the deletion trace
								rename $name {}
								rename $oldname $name
							}

						}
					}
				}
			}
		}


		proc .unknown {_ args} {
			namespace upvar [$_ .adminns] unknown unknown
			set unknown [upcall 1 namespace code $args]
		}


		variable {doc .upcall} {
			description {
				resolve the routine relative to the namespace of the caller
				and then [.eval] it as a prepared command
			}
		}
		proc .upcall {_ routine args} {
			set resolved [upcall 1 namespace which $routine] 
			if {$resolved eq {}} {
				error [list {unknown routine} $routine]
			}
			tailcall namespace eval [$_ .namespace] [list $resolved {*}$args]
		}


		proc .upvar {_ args} {
			set ns [$_ .namespace]
			upcall 1 namespace upvar $ns {*}$args
		}


		proc .varname {_ name} {
			return [join [$_ .namespace] $name]
		}


		proc .varexists {_ name} {
			set name [$_ .varname $name]
			expr {[namespace which -variable $name] ne {}}
		}


		proc .vars {_ args} {
			tailcall vars [$_ .namespace] {*}$args
		}


		proc .wrapped {_ args} {
			namespace upvar [$_ .adminns] wrapped wrapped
			lassign $wrapped 
			tailcall {*}$wrapped {*}$args
		}


		proc .wrap {_ target args} {
			if {![absolute? $target]} {
				lset target 0 [upcall 1 normalize $target]
			}
			namespace upvar [$_ .adminns] wrapped wrapped
			set wrapped [list $target {*}$args]
		}

		alias interp [join {} interp]

		foreach name {
			$
			$.exists
			=
			.act
			.adminns
			.allocate
			.apply
			.attribute
			.call
			.disposal
			.doattribute
			.doroutine
			.eject
			.eval
			.extend
			.filter
			.forward
			.insert
			.invoke
			.method
			.methods
			.name
			.namespace
			.next
			.nscall
			.nsdo
			.nsgen
			.object
			.rmproc
			.routine
			.routines
			.self
			.unfilter
			.unknown
			.upcall
			.varname
			.varexists
			.wrapped
			.vars
			.wrap
		} {
			nscall [namespace parent] namespace import [join [namespace current] $name]
		}
	}
}


variable {doc powerimport} {
	description {
		like [namespace import]

			but ensures that the named routine is imported
	}
}
proc powerimport {args} {
	foreach arg $args {
		set ns [namespace qualifiers $arg]
		if {$ns eq {}} {
			set ns [globalns]
		}
		set prevexports [upcall 1 namespace eval $ns {namespace export}]
		upcall 1 namespace eval $ns {namespace export *}
		upcall 1 namespace import $arg
		namespace eval $ns [list namespace export -clear {*}$prevexports]
	}
}


variable {doc prune} {
	description {
		Indicates whether or not to prune some child namespace while
		duplicating a namespace .
	}
	args {
		ns {
			description {
				the name of the namespace to test
			}
		}
	}
}


proc prune ns {
	set first [namespace tail $ns]
	lindex first 0
	expr {$first eq {$} || [string is digit $first]}
}


proc split nsname {
	upvar $nsname ns
	regsplit :::* ns 
	lmap {x y} ns {
		lindex_ $x
	}
	return
}


variable {doc this} {
	description {
		normalize $name 

		raise an error if $name doesn't exist 

		return $name
	}
}
proc this name {
	if {![absolute? $name]} {
		set name [upcall 1 normalize $name]
	}
	if {[namespace which $name] eq {}} {
		error [list {not found} $name]
	}
	return $name
}


variable {doc unique} {
	description {
		generate unique namespace names

		incremements [join $prefix $in $Id]
	}
	args {
		at {
			description {
				a namespace to start from
			}
			default {
				set at {}
			}
		}
		in {
			description {
				namespace relative to $at to create the unique namespace in
			}
			default {
				set in $UNIQUE_IN
			}
		}
		prefix {
			default {::lindex {}}
		}
		suffix {
			default {::lindex {}}
		}
	}
	value {
		a namespace which currently doesn't exist, and which this function will
		never return again
	}
}
proc unique args {
	variable structlist
	variable UNIQUE_IN
	variable Id
	checkargs [$ doc unique] {*}$args
	if {$at eq {}} {
		set at [namespace current]
	}
	while 1 {
		set id [join {*}[$structlist filter [
			list $at $prefix $in $prefix[incr Id]$suffix] {!= {}}]]
		if {![namespace exists $id]} break
	}
	return $id
}


proc vars args {
	set args [lassign $args[set args {}] namespace]
	if {$namespace eq {}} {
		set namespace [uplevel 1 {namespace current}]
	}
	set namespace [join $namespace[set namespace {}]]
	if {![llength $args]} {
		set args [upcall 1 info_ vars]
	}
	foreach var $args {
		if {![string is list $var]} {
			set var [list $var]
		}
		if {[llength $var] == 1} {
			lappend_ vars [lindex_ $var 0] [lindex_ $var 0]
		} else {
			lappend_ vars {*}$var 
		}
	}
	upcall 1 namespace upvar $namespace {*}$vars
	return
}


namespace eval objects {}


variable apply [join {} apply]
variable structlist [join {} struct list]
variable cleanly [string map [list @namespace@ [
	list [join {} namespace]]] {
	tailcall @namespace@ eval [namespace current] $script
}]
variable eval_ [which eval]
variable nscontents [string map [list @join@ [list [which join]]] {
	set pattern [@join@ [namespace current] *]
	list [namespace children] [info commands $pattern] [info vars $pattern]
}]

variable objwrapped [which objwrapped]

variable tailcall [string map [list @tailcall@ [join {} tailcall]] {
	@tailcall@ {*}$args
}]