if 0 { Being a former lisp freak who has switched to Tcl, in some nights when the moon is shining, my teeth grow, my hair becomes thick, and I dream of round (parens) instead of [brackets] and {braces} ...
}
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.
}
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 ...)
}
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.
(This is the only proper use of destructive functions imho.
To be honest, I do not like destructive functions.)
}
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, e.g. {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.
}
proc ::Pils::private::unParseList {data {sep " "}} {
join [map unParse $data] $sep
}
doc {
The procedures list? and atom? return true/false depending on data type.
}
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.
}
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.
}
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.
}
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:
}
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]]
}
[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 \")\")))"
}
}]
pils {(proc atan2 (a b) (tcl expr (string append atan2 "(" $a "," $b ")")))}
namespace import ::Pils::private::pils
namespace import -force ::Pils::private::*
# debug
proc translate x {
join [map ::Pils::private::expr2cmd [::Pils::private::parseList $x]] \n
}