Version 18 of Byticle

Updated 2007-12-15 15:59:44 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 ]

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

package provide byticle 0.2
namespace eval byticle {
	namespace export execute check get checknumber getnumber assert isnil
	variable binary
	variable unary
	variable functions
	variable params 0
	
	array unset binary *
	array unset unary *
	array unset functions *
	
	proc assert {expr {msg "assertion failed"}} {
		if {![uplevel 1 expr $expr]} {error $msg}
	}
	
	proc isnil {x} {string equal $x {nil nil}}
	
	# registers 'proc' as the implementation of 'name' with params types as 'params'
	proc register {name params proc} {
		assert {[llength $params]<3}
		register_[llength $params] $name $params [list func $proc]
	}
	
	proc register_0 {name params proc} {
		variable functions
		set functions($name) $proc
	}
	
	proc register_1 {name params proc} {
		variable unary
		set unary($name,$params) $proc
	}
	
	proc register_2 {name params proc} {
		variable binary
		set binary($name,[join $params ,]) $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 ""}
		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 ""}
		foreach {type first} $statement break
		switch -- $type {
			name {
				return ""
			}
			expr - pexpr {
				return [lindex $statement 2]
			}
			default {
				return {nil nil}
			}
		}
	}
	
	proc _getfunc {name argc val vnext} {
		upvar $val value
		upvar $vnext next
		getfunc_$argc $name value next
	}
	
	proc getfunc_0 {name value next} {
		variable functions
		assert {[info exists functions($name)]} "no such function: $name"
		set functions($name)
	}
	
	proc ary {var key} {
		upvar $var array
		llength [array names array $key]
	}
	
	proc getfunc_1 {name val vnext} {
		variable unary
		assert {[ary unary [unglob $name],*]} "no such unary operator: $name"
		upvar $vnext next
		set next [_exec $next]
		if {[info exists unary($name,[lindex $next 0])]} {
			foreach {type next} $next break
			return $unary($name,$type)
		}
		assert {[info exists unary($name,T)]} "no matching unary operator: $name ($type)"
		return $unary($name,T)
	}
	
	proc getfunc_2 {name val vnext} {
		variable binary
		set msg "no such binary operator: $name"
		assert {[ary binary [unglob $name],*]} $msg
		upvar $val value $vnext next
		foreach {ltype value} $value break
		if {[ary binary [unglob $name,$ltype],*]} {
			if {[ary binary [unglob $name,$ltype],*]==1 && [info exists binary($name,$ltype,T)]} {
				# lazy evaluation of right-side expressions
				return $binary($name,$ltype,T)
			}
			foreach {rtype next} [_exec $next] break
			if {[info exists binary($name,$ltype,$rtype)]} {
				return $binary($name,$ltype,$rtype)
			}
			if {[info exists binary($name,$ltype,T)]} {
				return $binary($name,$ltype,T)
			}
			set next [list $rtype $next]
		}
		set value [list $ltype $value]
		if {[ary binary [unglob $name,T],*]==1 && [info exists binary($name,T,T)]} {
			# allows for lazy evaluation
			return $binary($name,T,T)
		}
		foreach {rtype next} [_exec $next] break
		if {[info exists binary($name,T,$rtype)]} {
			return $binary($name,T,$rtype)
		}
		assert {[info exists binary($name,T,T)]} $msg
		set next [list $rtype $next]
		return $binary($name,T,T)
	}
	
	proc _exec {statement} {
		variable internals
		variable userdefined
		set value ""
		while {[llength $statement]} {
			foreach {type first} $statement break
			switch -- $type {
				name {
					set next [_next [lindex $statement 2]]
					set argc [expr {($value eq "")? (([llength $next])?1:0):2}]
					foreach {func fname} [_getfunc $first $argc value next] break
					switch -- $func {
						func {
							#puts "$fname $argc $value $next"
							switch $argc {
								0 {set value [$fname]}
								1 {set value [$fname $next]}
								2 {set value [$fname $value $next]}
							}
							set statement [_nextstatement [lindex $statement 2]]
						}
						proc {
							# TODO
						}
					}
				}
				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 params definition} $statement break
					register $name $params [list proc $definition]
				}
				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 tonumber {x} {
		if {[string is integer $x]} {return [list int $x]}
		list real $x
	}
	proc + {a b} {
		tonumber [expr {$a + $b}]
	}
	proc - {a b} {
		tonumber [expr {$a - $b}]
	}
	proc unary- {a} {
		tonumber [expr {-$a}]
	}
	proc * {a b} {
		tonumber [expr {$a * $b}]
	}
	proc / {a b} {
		tonumber [expr {$a / $b}]
	}
	proc % {a b} {
		list int [expr {$a % $b}]
	}
	proc fmod {a b} {
		list real [expr {fmod($a, $b)}]
	}
	proc puts_cmd {a} {
		puts -nonewline $a
	}
	proc newline {} {
		puts ""
	}
	proc car {a} {
		lindex $a 0
	}
	proc cdr {a} {
		lindex $a 1
	}
	proc cons {a b} {
		list list [list $a [get * $b]]
	}
	proc snoc {a b} {
		list list [list [get * $b] $a]
	}
	proc real {x} {
		list real $x
	}
	proc int {x} {
		list int $x
	}
	proc i2r {x} {
		list int [expr {int($x)}]
	}
	proc I {x} {set x}
	proc K {x y} {
		get * $y
		set x
	}
	proc register {name params proc} {
		byticle::register $name $params ::byticle::funcs::$proc
	}
}
# The Kombinator
byticle::funcs::register K {T T} K
# The Identity operator
byticle::funcs::register I T I
# Number conversions
byticle::funcs::register real real real
byticle::funcs::register real int  real
# Integer
byticle::funcs::register int int int
byticle::funcs::register int real i2r
foreach proc {+ - * /} {
	foreach x {int real} {
		byticle::funcs::register $proc [list $x $x] $proc
	}
}
byticle::funcs::register - int unary-
byticle::funcs::register - real unary-
byticle::funcs::register % {int int} %
byticle::funcs::register % {real real} fmod
byticle::funcs::register car {list} car
byticle::funcs::register cdr {list} cdr
byticle::funcs::register cons {T T} cons
byticle::funcs::register ~ {T T} snoc

byticle::funcs::register puts {string} puts_cmd
byticle::funcs::register newline {} newline

proc e x {byticle::execute $x}

Example

Byticle 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).

I also added to the language two well-known lambda-calculus combinators: K and I.

e {1 + 2 * 3}
e {(1 + 2) * 3}
e {car cdr (1 cons (2 cons 3))}
e {puts "Hello, world!"; newline}