Byticle is a codename for a fictive programming language. The goal is to build a language in which there is *quite* no keyword, with a generalized infix notation.
Larry Smith Like ee? [L1 ]
The relation with Tcl is the minimalism of the approach, the fact that tokens have spaces between them. It was inspired by Scheme because it will be functional, enforcing recursivity, but with infix notation instead of prefix.
2007-12-03 This project is being revitalized. -- Sarnold
package provide byticle 0.1
namespace eval byticle {
namespace export execute check get checknumber getnumber assert isnil
variable internals
variable userdefined
variable params 0
array unset internals *
array unset userdefined *
proc assert {expr {msg "assertion failed"}} {
if {![uplevel 1 expr $expr]} {error $msg}
}
proc isnil {x} {string equal $x {nil nil}}
proc register {name proc} {
variable internals
assert {![info exists internals($name)]}
assert {[llength [info procs [unglob $proc]]]}
set internals($name) $proc
}
proc check {type value} {
if {$type eq "*"} {return $value}
assert {[string equal [lindex $value 0] $type]} "type expected to be $type"
lindex $value 1
}
proc max {a b} {
expr {$a>$b ? $a : $b}
}
proc updateParam {p} {
variable params
switch -- $p {
X - `X {
set params [max $params 1]
}
Y - `Y {
set params [max $params 2]
}
}
}
proc parse {body} {
set result [list]
while {$body ne ""} {
foreach {id token sbody} [lex $body] {break}
if {$id eq "def"} {
foreach {statement body} [_parse $sbody yes] break
lappend result definition $statement
} else {
foreach {statement body} [_parse $body] break
lappend result statement $statement
}
}
return $result
}
proc in2 {elt list} {
expr {[lsearch -exact $list $elt]>=0}
}
proc params {params token} {
array set t2p {X X Y Y `X X `Y Y}
set param $t2p($token)
if {[in2 $param $params]} {
lappend params $param
}
return $params
}
proc isValue {id} {
in2 $id {nil boolean param int real string func}
}
proc isFunc {id} {
in2 $id {name func lambda}
}
proc priority {token} {
# lowest priority
if [in2 $token {then or}] {return 1}
if [in2 $token {not and}] {return 2}
if [in2 $token {> < <= >= = !=}] {return 3}
if [in2 $token {& | ^}] {return 4}
if [in2 $token {<< >>}] {return 5}
if [in2 $token {+ -}] {return 6}
if [in2 $token {* / %}] {return 7}
# highest priority (power)
if {$token eq "**"} {return 8}
#default
return 4
}
proc _parseOpen {bodyvar} {
upvar 1 $bodyvar body
set result ""
while {$body ne ""} {
foreach {id token body} [lex $body] {break}
if {[isValue $id]} {
lappend result expr [list $id $token] [_parseNextExpr body yes]
rework-priority result
} elseif {[isFunc $id]} {
lappend result $id $token [_parseExpr body yes]
} else {
switch $id {
eval {
lappend result eval [_parseOpen body] [_parseExpr body yes]
rework-priority result
}
open {
lappend result pexpr [_parseOpen body] [_parseNextExpr body yes]
}
close {
return $result
}
default {
if {$id eq "eos"} {error "unbalanced open parenthesis"}
error "unknown id : $id"
}
}
}
}
error "unbalanced open parenthesis"
}
proc _parseNextExpr {bodyvar {close no}} {
upvar 1 $bodyvar body
set result ""
while {$body ne ""} {
foreach {id token body} [lex $body] {break}
if {[isValue $id] || $id eq "open"} {
error "operator expected at: $token"
} elseif {[isFunc $id]} {
lappend result $id $token [_parseExpr body $close]
} else {
switch $id {
eval {
lappend result eval [_parseOpen body] [_parseExpr body $close]
}
close {
treatclose body
if {$close} {return $result}
error "unmatched close parenthesis"
}
eos {
if {$close} {error "unbalanced open parenthesis"}
treateos body
return $result
}
default {
error "unknown id : $id"
}
}
}
}
if {$close} {error "unbalanced open parenthesis"}
return $result
}
proc _parseExpr {bodyvar {close no}} {
upvar 1 $bodyvar body
set result ""
while {$body ne ""} {
foreach {id token body} [lex $body] {break}
if {[isValue $id]} {
lappend result expr [list $id $token] [_parseNextExpr body $close]
rework-priority result
} elseif {[isFunc $id]} {
lappend result $id $token [_parseExpr body $close]
} else {
switch $id {
eval {
lappend result eval [_parseOpen body] [_parseExpr body $close]
rework-priority result
}
open {
lappend result pexpr [_parseOpen body] [_parseNextExpr body $close]
}
close {
treatclose body
if {$close} {return $result}
error "unmatched close parenthesis"
}
eos {
if {$close} {error "unbalanced open parenthesis"}
treateos body
return $result
}
default {
error "unknown id : $id"
}
}
}
}
if {$close} {error "unbalanced open parenthesis"}
return $result
}
proc prio {tree} {
# default priority
set default 4
switch -- [lindex $tree 0] {
expr {
switch -- [lindex $tree 2 0] {
name {return [priority [lindex $tree 2 1]]}
lambda {return $default}
default {return -1}
}
}
default {return -1}
}
}
proc rework-priority {treevar} {
upvar 1 $treevar tree
set prio [prio $tree]
#puts "$prio $tree"
if {$prio == -1} {return}
set innerprio [prio [lindex $tree end end]]
# priority not applicable
if {$innerprio == -1} {return}
if {$innerprio > $prio} {
lset tree end end [list pexpr [lindex $tree end end] {}]
#puts "rework: $tree"
}
}
proc treatclose {var} {
upvar 1 $var body
set body )$body
}
proc treateos {var} {
upvar 1 $var body
set body \;$body
}
proc _parse {body {define no}} {
set result ""
variable params
set params 0
while {$body ne ""} {
foreach {id token body} [lex $body] {break}
if {[isValue $id]} {
lappend result expr [list $id $token] [_parseNextExpr body]
rework-priority result
} elseif {[isFunc $id]} {
lappend result $id $token [_parseExpr body]
} else {
switch $id {
eval {
lappend result eval [_parseOpen body] [_parseExpr body]
rework-priority result
}
open {
lappend result pexpr [_parseOpen body] [_parseNextExpr body]
}
eos {
if {!$define && $params} {error "X and Y are not allowed outside definitions"}
return [list $result $body]
}
default {
if {$id eq "close"} {error "unmatched close parenthesis"}
error "unknown id : $id"
}
}
}
}
if {!$define && $params} {error "X and Y are not allowed outside definitions"}
list $result $body
}
proc _next {statement} {
if {$statement eq ""} {return {nil nil}}
foreach {type first} $statement break
switch -- $type {
name {
return [_exec $statement]
}
expr {
return $first
}
pexpr {
return [_exec [lindex $statement 1]]
}
default {
return $statement
}
}
}
proc _nextstatement {statement} {
if {$statement eq ""} {return {nil nil}}
foreach {type first} $statement break
switch -- $type {
name {
return ""
}
expr - pexpr {
return [lindex $statement 2]
}
default {
return {nil nil}
}
}
}
proc _exec {statement} {
variable internals
variable userdefined
set value {nil nil}
while {[llength $statement]} {
foreach {type first} $statement break
switch -- $type {
name {
if {[info exists internals($first)]} {
set value [$internals($first) $value [_next [lindex $statement 2]]]
set statement [_nextstatement [lindex $statement 2]]
} elseif {[info exists userdefined($first)]} {
# TODO
} else {error "unknown operator: $first"}
}
expr {
set value $first
set statement [lindex $statement 2]
}
pexpr {
set value [_exec $first]
set statement [lindex $statement 2]
}
param {
# TODO
}
func {
# TODO
}
default {
return $statement
}
}
}
return $value
}
proc execute {body} {
variable builtins
variable userdefined
set value ""
foreach {type statement} [parse $body] {
switch -- $type {
statement {
set value [_exec $statement]
}
definition {
foreach {name definition} $statement break
if {[info exists builtins($name)]} {error "cannot redefine builtin $name"}
set userdefined($name) $statement
}
default {
error "unknown type $type"
}
}
}
set value
}
proc unglob {x} {
string map {* \\* ? \\? [ \\[ ] \\]} $x
}
proc get {type object} {
check $type [_exec $object]
}
proc checknumber {value} {
switch -- [lindex $value 0] {
int - real {return [lindex $value 1]}
default {error "not a number"}
}
}
proc getnumber {value} {
checknumber [_exec $value]
}
proc getstring {value} {
lindex [_exec $value] 1
}
# the lexer
proc lex {body} {
set keywords {def define lambda lambda nil nil
boolean true boolean false
open ( close ) eos ; eval `(}
foreach var {X Y A B} {lappend keywords param $var func `$var}
set patterns {
real {[+\-]?[0-9]+\.[0-9]+([eE][-+]?[0-9]+)?}
int {[+\-]?[0-9]+}
string {"([^"]*\\")*[^"]*"}
name {[a-z0-9+\-\*/%~\._!<>=@\|]+}
func {`[a-z0-9+\-\*/%~\._!<>=@\|]+}
}
set body [string trimleft $body " \t\n\r"]
while {[string index $body 0] eq "#"} {
set body [regsub {#.*$} $body ""]
set body [string trimleft $body " \t\n\r"]
}
foreach {id k} $keywords {
if {[string first $k $body]==0} {
updateParam $k
return [list $id $k [string range $body [string length $k] end]]
}
}
foreach {id pat} $patterns {
set patb "^${pat}\[ \\t\]+"
if {[regexp $patb $body] || [regexp "^${pat}\\)" $body] || [regexp "^${pat};?" $body]} {
regexp "^$pat" $body token
set len [string length $token]
if {$id eq "string"} {
set token [string range $token 1 end-1]
}
return [list $id $token [string range $body $len end]]
}
}
if {[regexp {^\s*$} $body]} {
return [list end "" ""]
}
error "syntax error : $body"
}
}
namespace eval byticle::funcs {
namespace import ::byticle::*
proc checknil {x} {assert [isnil $x]}
proc tonumber {x} {
if {[string is integer $x]} {return [list int $x]}
list real $x
}
proc + {a b} {
tonumber [expr {[checknumber $a] + [getnumber $b]}]
}
proc * {a b} {
tonumber [expr {[checknumber $a] * [getnumber $b]}]
}
proc - {a b} {
if {[isnil $a]} {
# unary -
return [tonumber [expr {-[getnumber $b]}]]
}
tonumber [expr {[checknumber $a] - [getnumber $b]}]
}
proc / {a b} {
tonumber [expr {[checknumber $a] / [getnumber $b]}]
}
proc % {a b} {
if {[string is integer [checknumber $a]]} {
# integer remainder
return [tonumber [expr {[checknumber $a] % [getnumber $b]}]]
}
tonumber [expr {fmod([checknumber $a], [getnumber $b])}]
}
proc puts_cmd {a b} {
checknil $a
puts [getstring $b]
}
proc car {a b} {
checknil $a
lindex [get list $b] 0
}
proc cdr {a b} {
checknil $a
lindex [get list $b] 1
}
proc cons {a b} {
list list [list $a [get * $b]]
}
}
foreach proc {+ - * / % car cdr cons} {
byticle::register $proc ::byticle::funcs::$proc
}
byticle::register puts ::byticle::funcs::puts_cmdByticle has cons, car and cdr, right from LISP. The syntax is simple: operations are evaluated left-to-right, except when parentheses or predefined priorities (like * over +) apply.
When an operator follows another operator, or the beginning of an expression, it is treated as unary. cons, +, * and / are binary operators. car and cdr are exclusively unary, while for -, it is unary or binary, depending of the context. You may put parentheses when necessary for the comprehension, but predefined priorities should allow code to behave like it looks (at least, I hope so).
byticle::execute {1 + 2 * 3}
byticle::execute {(1 + 2) * 3}
byticle::execute {car cdr (1 cons (2 cons 3))}