interp alias {} ? {} set errorInfo
 proc -- args {}
 -- {
     If you need multi-line comments, use -- instead of #.

     If you want to comment out a proc definition, use it too.
 }

 proc doc args {
     foreach arg $args {
         append ::doc \n [string trim $arg \n] \n
     }
 }

 -- {
     If you want to document, use this:
     doc {
         ... this is what I intended ...
     }
     The proc doc is some kind of "poor man's literate programming".
 }

 doc {
     This is Pils. The name is an anagram of Lisp.

     Pils is a tiny lisp, made as Tcl-ish as possible.
     List are not cons'd such that no element nil is necessary.
     Instead, the empty list () is a "true" list.
     But it is treated as boolean false.

     While Tcl has exactly 1 data type,
     Pils has exactly 2:
     (a) the atom,
     (b) the list.
     There are even no symbols as every atom can serve as such!

     By the way, in Germany Pils is pronounced "beer"
     except in Cologne where Koelsch has this pronounciation.
     German pronounciation is not a science but an art.

     AvL: Oh, be fair: this is not a language-phonetic
        peculiarity.  Pils is just one type of beer.
 }

 proc echo args {puts $args}
 proc vertical args {join [uplevel $args] \n}
 proc sourceCode p {
     list\
         [namespace origin proc]\
         [namespace origin $p]\
         [info args $p]\
         [info body $p]
 }
 doc {
     The namespace Pils contains the lisp procedures.
     The namespace Pils::private contains helper procedures.
 }

 namespace eval Pils {
     namespace eval private {
         namespace export *
     }
 }

 doc {
     The procedures map, not, let, and shift
     do just what the name suggests:
 }

 proc ::Pils::private::map {f l} {
     set result {}
     foreach e $l {
         lappend result [uplevel [list $f $e]]
     }
     set result
 }
 proc ::Pils::private::not bool {expr {$bool ? false : true}}
 proc ::Pils::private::let args {uplevel foreach $args break}
 proc ::Pils::private::shift {stackVar} {
     upvar $stackVar stack
     set result [lindex $stack 0]
     set stack [lrange $stack 1 end]
     set result
 }
 proc ::Pils::private::second l {lindex $l 1}

 doc\
     [sourceCode ::Pils::private::map]\
     [sourceCode ::Pils::private::not]\
     [sourceCode ::Pils::private::let]\
     [sourceCode ::Pils::private::shift]\
     [sourceCode ::Pils::private::second]

 doc {
     The procedure tokenise takes the source text
     and returns a stream of type val type val
     where type is either data or control
     and val is either an atom or ( or ) or such.

     Processing of special chars -- immediately:

     ; # line comment -- rest of line is ignored
     ""  double-quotes group chars to atoms
     \   prevents from special handling: \; \" \( \) \$ \'

     Recognising more special chars:

     ()  parens, intended for grouping to lists
     $   dollar sign, intended as shortcut for (set ...)
     '   quote, intended as shortcut for (quote ...)

     Example:

     % Pils::private::tokenise {apple ('c $d)}
     data apple control ( control ' data c control {$} data d control )
     %
 }

 proc ::Pils::private::tokenise text {
     set verbatim no
     set quoteMode no
     set commentMode no
     set tokens {}
     set token ""
     foreach c [split $text ""] {
         if {$commentMode} then {
             if {$c eq "\n"} then {
                 set commentMode no
             }
         } elseif {$verbatim} then {
             append token $c
             set verbatim no
         } else {
             set verbatim no
             switch -- $c {
                 \\ {
                     set verbatim yes
                 }
                 ; - \# {
                     if {$quoteMode} then {
                         append token $c
                     } else {
                         if {$token ne ""} then {
                             lappend tokens data $token
                             set token ""
                         }
                         set commentMode yes
                     }
                 }
                 \" {
                     if {$quoteMode} then {
                         # the only way to create an empty token
                         lappend tokens data $token
                         set token ""
                     } elseif {$token ne ""} then {
                         lappend tokens data $token
                         set token ""
                     }
                     set quoteMode [not $quoteMode]
                 }
                 ( - ) - " " - \n - \t - ' - $ {
                     if {$quoteMode} then {
                         append token $c
                     } else {
                         if {$token ne ""} then {
                             lappend tokens data $token
                             set token ""
                         }
                         if {[string is graph $c]} then {
                             lappend tokens control $c
                         }
                     }
                 }
                 default {
                     append token $c
                 }
             }
         }
     }
     if {$token ne ""} then {
         lappend tokens data $token
     }
     set tokens
 }

 doc {
     The procedure tokensVar2List takes the name of a var containing tokens,
     and builds internal lisp data.
     For practical reasons (recursion on lists),
     the variable is changed destructively.
     Returns list of data where
     each date is an atom {1 ...} or a list {0 {...}}

     The control tokens $ and ' are processed with processCtrlTokensVar.

     The procedure parseList collects the tokens to a local variable
     and calls the procedure tokensVar2List to gain the data.

     Example:

     % Pils::private::parseList {x (a apple) b}
     {1 x} {0 {{1 a} {1 apple}}} {1 b}
     %
 }

 proc ::Pils::private::processCtrlTokensVar {tokensVar levelVar key} {
     upvar $tokensVar tokens
     upvar $levelVar level
     if {[llength $tokens] == 0} then {
         return -code error [list $key without value]
     } else {
         list 0 [concat\
                     [list [list  1 $key]]\
                     [tokensVar2List tokens level 1]]
     }
 }

 proc ::Pils::private::tokensVar2List {tokensVar levelVar {count -1}} {
     upvar $tokensVar tokens
     upvar $levelVar level
     # attention -- destuctive!
     set result {}
     while {[llength $tokens] && $count} {
         set type [shift tokens]
         set token [shift tokens]
         if {$type eq "data"} then {
             lappend result [list 1 $token]
         } else {
             switch -- $token {
                 \' {
                     lappend result [processCtrlTokensVar tokens level quote]
                 }
                 \$ {
                     lappend result [processCtrlTokensVar tokens level set]
                 }
                 \( {
                     incr level
                     lappend result [list 0 [tokensVar2List tokens level]]
                 }
                 \) {
                     incr level -1
                     break
                 }
             }
         }
         incr count -1
     }
     set result
 }

 proc ::Pils::private::parseList text {
     set tokens [tokenise $text]
     set level 0
     set result [tokensVar2List tokens level]
     if {$level > 0} then {
         return -code error\
             [list unmatched opening paren in expression $text]
     } elseif {$level < 0} then {
         return -code error\
             [list unmatched closing paren in expression $text]
     }
     set result
 }

 doc {
     The procedure unParse returns the human readable source.
     of a single lisp date.

     Example:

     % Pils::private::unParse {0 {{1 a} {1 apple}}}
     (a apple)
     %
 }

 proc ::Pils::private::unParse data {
     if {$data eq {}} then {
         return ""
     }
     let {isAtom val} $data
     if {$isAtom} then {
         regsub -all (^\{)|(\}$) [list [string map {
             \\ \\\\ \' \\\' \( \\\( \) \\\) \" \\\" \$ \\\$
         } $val]] \"
     } elseif {[llength $val] == 2
               &&
               [lindex $val 0 0] == 1
               &&
               [regexp ^(set|quote)$ [lindex $val 0 1]]} then {
         array set specialChar {
             quote \'
             set \$
         }
         set result $specialChar([lindex $val 0 1])
         append result [unParse [lindex $val 1]]
     } else {
         set result ([join [map unParse $val]])
     }
 }

 doc {
     The procedure unParseList returns the human readable source
     of a Tcl list of lisp data.

     % Pils::private::unParseList {
         {0 {{1 a} {1 apple}}}
         {0 {{1 t} {1 tree}}}
     }
     (a apple) (t tree)
     %
 }

 proc ::Pils::private::unParseList {data {sep " "}} {
     join [map unParse $data] $sep
 }

 doc {
     The procedures list? and atom? return true/false depending on data type.

     Example:

     % Pils::private::list? {1 apfel}
     false
     % Pils::private::atom? {1 apfel}
     true
     %
 }

 proc ::Pils::private::list? datum {
     expr {[lindex $datum 0] == 0 ? true : false}
 }

 proc ::Pils::private::atom? datum {
     expr {[lindex $datum 0] == 1 ? true : false}
 }

 doc {
     The procedure true? returns false if its argument is an empty list
     or if it is an atom and its value obeys Tcl's "string is false $x",
     else returns true.

     Example

     % Pils::private::true? {1 anything-but-false}
     true
     %
 }

 proc ::Pils::private::true? datum {
     if {[lindex $datum 0]} then {
         expr {[string is false -strict [lindex $datum 1]] ? false : true}
     } else {
         expr {[llength [lindex $datum 1]] ? true : false}
     }
 }

 doc {
     The procedure expr2tcl converts a Lisp list to a Tcl list.

     Example:

     % Pils::private::expr2tcl {0 {{1 a} {0 {{1 x} {1 y}}} {1 b}}}
     a {x y} b
     %
 }

 proc ::Pils::private::expr2tcl x {
     if {[atom? $x]} then {
         lindex $x 1
     } else {
         map expr2tcl [lindex $x 1]
     }
 }

 doc {
     The procedure expr2varName takes an atom or a list with 2 elements.
     If it is an atom, its value is returned, e.g.

     % expr2varName {1 a}
     a
     %

     If it is a list, then it returns as el1(el2), e.g.

     % expr2varName {0 {{1 fruit} {1 a}}}
     fruit(a)
     %

     This is the way Pils handles array names.
 }

 proc ::Pils::private::expr2varName x {
     if {[atom? $x]} then {
         expr2tcl $x
     } else {
         set l [lindex $x 1]
         if {[llength $l] != 2} then {
             return -code error\
                 [list array name needs list with 2 names\
                      but received [unParse $x]]
         } else {
             set result [expr2tcl [lindex $l 0]]
             append result ( [expr2tcl [lindex $l 1]] )
         }
     }
 }

 doc {
     The procedure expr2cmd converts an expression to a proc calling string.

     Example:

     % Pils::private::expr2cmd {0 {{1 atan2} {1 5} {1 11}}}
     atan2 {1 5} {1 11}
     %
 }

 proc ::Pils::private::expr2cmd x {
     let {type value} $x
     if {$type == 1} then {
         set result "quote [list $x]"
     } elseif {[llength $value]} then {
         # x is a non-empty list
         set first [lindex $value 0]
         set name [lindex $first 1]
         if {[info command special_$name] ne "" && $name ne "*"} then {
             eval special_$name [lrange $value 1 end]
         } else {
             set result $name
             foreach el [lrange $value 1 end] {
                 if {[atom? $el]} then {
                     append result " " [list $el]
                 } else {
                     append result " \[" [expr2cmd $el] "\]"
                 }
             }
             set result
         }
     } else {
         # x is ()
         list quote $x
     }
 }

 doc {
     The procedure expr2true? returns the source code for testing
     if a lisp date counts as true.
 }

 proc ::Pils::private::expr2true? cmd {
     set result private::true?
     append result " " \[ [expr2cmd $cmd] \]
 }

 doc {
     All procedures the name of which starts with "special_"
     are treated by expr2cmd as special forms.

     Example:

     % Pils::private::special_begin\
         {0 {{1 brumm} {1 x}}}\
         {0 {{1 dumm} {1 y}}}

     brumm {1 x}
     dumm {1 y}

     %
 }

 proc ::Pils::private::special_begin args {
     set result \n[join [map expr2cmd $args] \n]\n
 }

 proc ::Pils::private::special_quote args {
     concat quote $args
 }

 proc ::Pils::private::special_if {cond thenClause args} {
     set result ::if
     lappend result \[[expr2true? $cond]\] then [expr2cmd $thenClause]
     if {[llength $args] % 2 == 0} then {
         lappend args [list 0 ""]
     }
     foreach {elseCond elseClause} [lrange $args 0 end-1] {
         lappend result\
             elseif \[[expr2true? $elseCond]\] [expr2cmd $elseClause]
     }
     lappend result else [expr2cmd [lindex $args end]]
     set result
 }

 proc ::Pils::private::special_while {cond args} {
     list ::while \[[expr2true? $cond]\] [eval special_begin $args]
 }

 proc ::Pils::private::special_proc {name arglist args} {
     if {$arglist eq {1 args}
         ||
         [lindex $arglist end end] eq {1 args}} then {
         set cmd \n
         append cmd {::set args [::list 0 $args]}
     } else {
         set cmd ""
     }
     list proc [expr2tcl $name] [expr2tcl $arglist]\
         $cmd[eval special_begin $args]
 }

 doc {
     The procedure ::Pils::private::tcl is invoked by ::Pils::tcl.
     It is intended as fallback for all non-list-related functions.
 }

 proc ::Pils::private::tcl args {
     eval [list uplevel \#0 [list namespace inscope :: $args]]
 }

 doc {
     The procedure pils parses its argument (if given) as lisp data
     and returns the evalued lisp datum, e.g.

     % pils (set a apple)
     apple
     % pils {(list "a b" c)}
     ("a b" c)
     %

     The procedure pils with no argument enters the read-eval-print loop:

     % pils
     Pils> (list a is $a)
     (a is apple)
     Pils>

     To leave the read-eval-print loop, press <Enter> without input data.
 }

 proc ::Pils::private::pils args {
     if {[llength $args] == 1} then {
         set args [lindex $args 0]
     }
     if {$args ne ""} then {
         set data [parseList $args]
         set cmds [map expr2cmd $data]
         set resL {}
         foreach cmd $cmds {
             lappend resL [uplevel [list namespace inscope ::Pils $cmd]]
         }
         unParseList $resL \n
     } else {
         while true {
             puts -nonewline {Pils> }
             flush stdout
             set input [gets stdin]
             if {$input eq ""} then {
                 break
             } else {
                 if {[catch {
                     set feedback [uplevel [list pils $input]]
                     if {$feedback ne {""} && $feedback ne ""} then {
                         puts $feedback
                     }
                 } err]} then {
                     puts stderr $err
                 }
             }
         }
     }
 }

   #             ####
  ##      ##### ####
 ###   ####### ####
 ###  ###     #### ###
 ### ###     ####   ###   End of namespace ::Pils::private
 ### ###    ####    ###   Starting overloading procs in namespace ::Pils
 ### ###   ####     ###   *Danger* -- use Tcl commands with leading :: only!
 ###  ### ####     ###
 ###     #### #######
 ##     #### #####
 #     ####

 proc ::Pils::quote x {
     ::set x
 }

 proc ::Pils::proc {name arglist body} {
     ::list 1 [::proc $name $arglist $body]
 }

 # above are special forms, below are regular procedures

 proc ::Pils::eval {l} {
     ::eval [private::expr2cmd $l]
 }

 proc ::Pils::list args {::list 0 $args}

 proc ::Pils::join {l {sep {1 " "}}} {
     ::list 1\
         [::join\
              [private::map private::second [::lindex $l 1]]\
              [::lindex $sep 1]]
 }

 proc ::Pils::concat args {
     ::list 0\
         [::eval ::concat\
              [private::map private::second $args]]
 }

 proc ::Pils::lindex {l args} {
     ::set indices {}
     ::foreach arg $args {
         ::lappend indices 1 [::lindex $arg 1]
     }
     ::eval [::list ::lindex $l] $indices
 }

 doc {
     In Pils, vars and arrays are handled as follows:
     {Tcl: set a apple}          {Pils -- (set a apple)}
     {Tcl: set fruit(a) apple}   {Pils -- (set '(fruit a) apple)}
     {Tcl: $fruit(a)}            {Pils -- $'(fruit a)}
     {Tcl: $fruit(a)}            {Pils -- $(list fruit a)}
 }

 proc ::Pils::set {varName args} {
     ::if {[::lindex $varName 0]} then {
         ::uplevel [::list ::set [::lindex $varName 1]] $args
     } else {
         ::set arr [::lindex $varName 1 0 1]
         ::set key [::lindex $varName 1 1 1]
         ::uplevel [::list ::set ${arr}($key)] $args
     }
 }

 proc ::Pils::lset {varName args} {
     ::upvar [private::expr2varName $varName] var
     ::set indices {}
     ::foreach arg [::lrange $args 0 end-1] {
         ::lappend indices 1 [::lindex $arg 1]
     }
     ::eval [::list ::lset var] $indices [::lrange $args end end]
 }

 proc ::Pils::llength l {
     ::list 1 [::llength [::lindex $l 1]]
 }

 proc ::Pils::lrange {l from to} {
     ::list 0 [::lrange [::lindex $l 1] [::lindex $from 1] [::lindex $to 1]]
 }

 proc ::Pils::lsearch {l e} {
     ::list 1 [::lsearch [::lindex $l 1] $e]
 }

 proc ::Pils::lappend {varName args} {
     ::upvar [private::expr2varName $varName] var
     ::set l [::lindex $var end]
     ::eval ::lappend l $args
     ::lset var end $l
     ::set var
 }

 proc ::Pils::split {strObj {sepObj {1 " "}}} {
     ::set str [private::expr2tcl $strObj]
     ::set sep [private::expr2tcl $sepObj]
     ::set l {}
     ::foreach el [::split $str $sep] {
         ::lappend l [::list 1 $el]
     }
     ::list 0 $l
 }

 proc ::Pils::string args {
     ::set subcmdObj [::lindex $args 0]
     ::if {$subcmdObj eq {1 append}} then {
         ::set result ""
         ::eval append result\
             [private::map private::second [::lrange $args 1 end]]
         ::list 1 $result
     } else {
         ::list 1 [::eval ::string [private::map private::second $args]]
     }
 }

 proc ::Pils::tcl args {
     ::list 1\
         [::eval [::list private::tcl] [private::map private::expr2tcl $args]]
 }

 doc {
     Mathematical operations are made with a foreach-loop.

     Every Tcl command which is not a proc,
     and which is not yet defined in namespace ::Pils
     and which is assumed to operate on string => string,
     is defined via (tcl cmd ...)
 }

 [proc "" {} {
     set p ::Pils::private::pils
     foreach op {+ - * / % < > <= >= != ==} {
         $p "(proc $op args (tcl expr (join \$args $op)))"
     }
     foreach sin [info functions] {
         $p "(proc $sin x (tcl expr (string append $sin \"(\" \$x \")\")))"
     }
     $p {(proc atan2 (a b) (tcl expr (string append atan2 "(" $a "," $b ")")))}

     set procs [info procs]
     foreach c [info commands] {
         if {[lsearch $procs $c] < 0
             &&
             [info command ::Pils::$c] eq ""
             &&
             [lsearch {
                 foreach
                 while
                 if
                 set
                 for
             } $c] < 0} then {
             $p "(proc $c args (eval (concat (list tcl $c) \$args)))"
         }
     }
 }]

 namespace import ::Pils::private::pils

 catch {console show}

 pils