Version 10 of Byticle

Updated 2007-12-02 20:46:23 by sarnold

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


The source

 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
                                 return [list $id $token [string range $body [string length $token] 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 {$x eq "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}