##########  
#
#  Lisplike example in ParentheTcl
#

if [llength [info commands p7proc]] {
	set Compiling true
} else {
	set Compiling false
	source testing.tcl
}

if $Compiling {

	# A lisp "SNode" contains a left and a right.
	# Left may be anything, but right must always be another SNode, or null.

	p7class SNode { (tcl)left (SNode)right }

	# "cons" allocates a new SNode with its two parameters

	p7proc (SNode)cons { (tcl)a (SNode)b } {
	    set (SNode)z [new (SNode)]
	    set z(left) $a
	    set z(right) $b
	    k $z
	}

	# "car" gets the left slot
	p7proc (tcl)car { (SNode)x } { k $x(left) }

	# "cdr" gets the right slot
	p7proc (SNode)cdr { (SNode)x } { k $x(right) }

} else { #testing

			AssertEq red  {       car [ cons red [ cons blue "" ] ] }
			AssertEq blue { car [ cdr [ cons red [ cons blue "" ] ] ] }
			AssertEq ""   { cdr [ cdr [ cons red [ cons blue "" ] ] ] }

}

if $Compiling {

	# anything except an SNode is an atom
	p7proc (int)atomp { (tcl)this } { k 1 }
	p7proc (int)atomp { (SNode)this } { k 0 }

} else { #testing

			AssertEq 1 { atomp "hello" }
			AssertEq 0 { atomp [cons blue ""] }	;#  a list is not an atom
			AssertEq 1 { atomp ""  }  		;#  null IS an atom
}

if $Compiling {

	# only null is false
	p7proc (int)not	{ (tcl)arg } { k ( arg eq null ) }

} else { # Testing

			AssertEq 0 { not "hello" }
			AssertEq 0 { not [cons blue ""] }
			AssertEq 1 { not "" }
}

#if $Compiling {
#
#	# lookup in an environment list, which is ( key value key value ... )
#	p7proc (tcl)lookup { (tcl)thing (SNode)env } {
#		if ( env eq null ) {
#			return null
#		} elseif ( [car $env] eq thing ) {
#			return ( [car [cdr $env]] )
#		} else {
#			return [ lookup $thing [ cdr [ cdr $env ] ] ]
#		}
#	}
#
#} else { # Testing
#
#			AssertEq 0 { not "hello" }
#			set s4 [cons four $s3]
#			AssertEq three { lookup four $s4 }
#			AssertEq one { lookup two $s4 }
#			AssertEq "" { lookup xxxxx $s4 }
#}

if $Compiling {

	# lookup in an environment list, which is ( key value key value ... )
	p7proc (tcl)lookup { (tcl)thing (SNode)env } {
		if ( env eq null ) {
			return null
		} elseif ( env.left eq thing ) {
			return ( env.right.left )
		} else {
			return [lookup $thing (env.right.right)]
		}
	}

} else { # Testing

		AssertEq 0 { not "hello" }
		set s4 [cons four [cons three [cons two [cons one ""]]]]
		AssertEq three { lookup four $s4 }
		AssertEq one { lookup two $s4 }
		AssertEq "" { lookup xxxxx $s4 }
}



if $Compiling {

	##########  For a 'reverse' test
	#
	#

	# "append_item" returns a new lisp list, with the item added to the end.
	# It's used as a subroutine by "reverse".
	p7proc (SNode)lisp_append_item { (SNode)list (tcl)item } {
	    if ($list==null) { return [cons $item (null)] }
	    cons [car $list] [lisp_append_item [cdr $list] $item]
	}
	    
	# "reverse" returns a new lisp list, with items in reverse order.
	p7proc (SNode)lisp_reverse { (SNode)x } {
	    if ($x==null) {return $x}
	    lisp_append_item [lisp_reverse [cdr $x]] [car $x]
	}

	# Create a Lisp List from a Tcl List
	p7proc (SNode)list_to_lisp { (tcl)x } {
	    set (SNode)z (null)
	    set (int)n [len $x]
	    for {set (int)i ($n-1)} ($i>=0) {incr i (0-1)} {
		set z [cons $x($i) $z]
	    }
	    k $z
	}

	# Create a Tcl List from a Lisp List
	p7proc (tcl)lisp_to_list_2 { (SNode)p } {
	    ::set _tmp_ ""
	    while ( $p!=null ) {
		::lappend _tmp_ [car $p]
		set p [cdr $p]
	    }
	    ::set _tmp_
	}
	p7proc (tcl)lisp_to_list { (SNode)p } {
	    set (tcl)z {}
	    while ( $p!=null ) {
		lappend z [car $p]
		set p [cdr $p]
	    }
	    set z
	}

	# Lisp List Length
	p7proc (int)lisp_length { (SNode)p } {
	    if ( $p==null ) {
		return 0
	    } else {
		return (1 + [lisp_length [cdr $p]])
	    }
	}
		




} else { # if Testing

			set s0 ""
			set s1 [cons one ""]
			set s2 [cons two $s1]
			set s3 [cons three $s2]

			set r0 [lisp_reverse $s0]
			set r1 [lisp_reverse $s1]
			set r2 [lisp_reverse $s2]
			set r3 [lisp_reverse $s3]

			AssertEq 0 {lisp_length $s0}
			AssertEq 1 {lisp_length $s1}
			AssertEq 2 {lisp_length $s2}
			AssertEq 3 {lisp_length $s3}

			AssertEq 0 {lisp_length $r0}
			AssertEq 1 {lisp_length $r1}
			AssertEq 2 {lisp_length $r2}
			AssertEq 3 {lisp_length $r3}

			proc ToString x {
			    if { $x=="" } {return NIL}
			    return "([car $x] . [ToString [cdr $x]])"
			}


			AssertEq NIL { ToString $s0 }
			AssertEq "(one . NIL)" { ToString $s1 }
			AssertEq "(two . (one . NIL))" { ToString $s2 }
			AssertEq "(three . (two . (one . NIL)))" { ToString $s3 }
			AssertEq "(one . (two . (three . NIL)))" { ToString $r3 }

			#################################################

			AssertEq [ToString $s0] { ToString [ lisp_reverse $r0 ] }
			AssertEq [ToString $s1] { ToString [ lisp_reverse $r1 ] }
			AssertEq [ToString $s2] { ToString [ lisp_reverse $r2 ] }
			AssertEq [ToString $s3] { ToString [ lisp_reverse $r3 ] }

			set big 99 ;# stay under TCL stack limit 1000
			set a ""
			set b ""
			for {set i 0} {$i<=$big} {incr i} {set a [cons node$i $a]}
			for {set i $big} {$i>=0} {incr i -1} {set b [cons node$i $b]}

			incr big
			AssertEq $big { lisp_length $a }
			AssertEq $big { lisp_length $b }

			AssertEq [ToString $a] { ToString [lisp_reverse $b] }

			AssertError * { lisp_reverse "not a Node" }

}


if $Compiling {

	# Lisp List Repeat
	p7proc (SNode)lisp_repeat { (tcl)item (int)count } {
	    if ( $count==0 ) { return (null) }
	    cons $item [lisp_repeat $item (count-1)]
	}


	p7proc tcl_repeat_p7 {item count} {
	    set (tcl)z
	    loop (int)i $count {
		# this is slow because the result of lappend is kept in a temporary ):
		lappend z $item
	    }
	    k $z
	}

	# "pi" returns a Tcl of pi
	p7proc (tcl)pi { } { return "3.1415926536" }

} else { # Testing

			proc tcl_repeat {item count} {
			    set z {}
			    for {set i 0} {$i<$count} {incr i} {
				lappend z $item
			    }
			    set z
			}

			set t_r	    [ tcl_repeat [pi] 111 ]
			set t_r_p7  [ tcl_repeat_p7 [pi] 111 ]
			set l_r	    [ lisp_repeat [pi] 111 ]

			AssertEq	$t_r	{set t_r_p7}
			AssertEq 	$t_r	{lisp_to_list $l_r}
			AssertMatch	SNode@*	{list_to_lisp $t_r}
			AssertEq	111	{lisp_length $l_r}
			AssertEq	$t_r	{lisp_to_list [list_to_lisp $t_r]}
			AssertEq  [ToString $l_r] {ToString [lisp_reverse $l_r]}

Okay

}