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? [http://lang2e.sourceforge.net/about.html] [Lars H]: Or [infix]? ---- 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]'' ---- '''The source''' #!/bin/env tclsh package provide byticle 0.1 namespace eval byticle { 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 register {name proc} { variable internals assert {![info exists internals($name)]} assert {[llength [info procs [unglob $proc]]]} set internals($name) $proc } proc check {type value} { assert {[lindex $value 0] eq $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 integer 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" } } } } #puts $result 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 _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)]} { return [$internals($first) $value [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] { integer - 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 { integer {[+\-]?[0-9]+} real {[+\-]?[0-9]+\\.[0-9]+([eE][-+]?[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 ""] } 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 { proc checknum {x} {byticle::checknumber $x} proc getnum {x} {byticle::getnumber $x} proc getstring {x} {byticle::getstring $x} proc isnil {x} {byticle::assert [string equal $x {nil nil}]} proc tonumber {x} { if {[string is integer $x]} {return [list integer $x]} list real $x } proc + {a b} { tonumber [expr {[checknum $a] + [getnum $b]}] } proc * {a b} { tonumber [expr {[checknum $a] * [getnum $b]}] } proc puts_cmd {a b} { isnil $a puts [getstring $b] } } foreach proc {* +} { byticle::register $proc ::byticle::funcs::$proc } byticle::register puts ::byticle::funcs::puts_cmd ---- '''Example''' byticle::execute {1 + 2 * 3} byticle::execute {(1 + 2) * 3} ---- !!!!!! %| [Category Concept] | [Category Language] |% !!!!!!