1# ### ### ### ######### ######### ######### 2## 3# (c) 2008-2009 Andreas Kupries. 4 5# WIP = Word Interpreter (Also a Work In Progress :). Especially while 6# it is running :P 7 8# Micro interpreter for lists of words. Domain specific languages 9# based on this will have a bit of a Forth feel, with the input stream 10# segmented into words and any other structuring left to whatever 11# language. Note that we have here in essence only the core dispatch 12# loop, and no actual commands whatsoever, making this definitely only 13# a Forth feel and not an actual Forth. 14 15# The idea is derived from Colin McCormack's treeql processor, 16# modified to require less boiler plate within the command 17# implementations, at the expense of, likely, execution speed. In 18# addition the interface between processor core and commands is more 19# complex too. 20 21# ### ### ### ######### ######### ######### 22## Requisites 23 24package require Tcl 8.4 25 26# For Tcl 8.{3,4} only snit1 of a suitable patchlevel is possible. 27package require snit 1.3 28 29# The run_next_* methods use set operations (x in set) 30package require struct::set 31 32# ### ### ### ######### ######### ######### 33## API & Implementation 34 35snit::type ::wip { 36 37 # ### ### ### ######### ######### ######### 38 ## API 39 40 constructor {e args} {} ; # create processor 41 42 # Defining commands and where they dispatch to. 43 method def {name {cp {}}} {} ; # Define a DSL command. 44 method def/ {name arity {cp {}}} {} ; # Ditto, with explicit arity. 45 method defl {names} {} ; # Def many, simple names (cp = name) 46 method defd {dict} {} ; # s.a. name/cp dict 47 method deflva {args} {} ; # s.a. defl, var arg form 48 method defdva {args} {} ; # s.a. defd, var arg form 49 50 method undefva {args} {} ; # Remove DSL commands from the map. 51 method undefl {names} {} ; # Ditto, names given as list. 52 53 # Execution of word lists. 54 method runl {alist} {} ; # execute list of words 55 method run {args} {} ; # ditto, words as varargs 56 method run_next {} {} ; # run the next command in the input. 57 method run_next_while {accept} {} ; # s.a., while acceptable command 58 method run_next_until {reject} {} ; # s.a., until rejectable command 59 method run_next_if {accept} {} ; # s.a., if acceptable command 60 method run_next_ifnot {reject} {} ; # s.a., if not rejectable command 61 62 # Manipulation of the input word list. 63 method peek {} {} ; # peek at next word in input 64 method next {} {} ; # pull next word from input 65 method insert {at args} {} ; # insert words back into the input 66 method push {args} {} ; # ditto, at == 0 67 68 # ### ### ### ######### ######### ######### 69 ## Processor construction. 70 71 constructor {e args} { 72 if {$e eq ""} { 73 return -code error "No engine specified" 74 } 75 set engine $e 76 $self unknown [mymethod ErrorForUnknown] 77 $self Definitions $args 78 return 79 } 80 81 method Definitions {alist} { 82 # args = series of 'def name' and 'def name cp' statements. 83 # The code to handle them is in essence a WIP too, just 84 # hardcoded, as state machine. 85 86 set state expect-def 87 set n {} 88 set cp {} 89 foreach a $alist { 90 if {$state eq "expect-def"} { 91 if {$a ne "def"} { 92 return -code error "Expected \"def\", got \"$a\"" 93 } 94 set state get-name 95 } elseif {$state eq "get-name"} { 96 set name $a 97 set state get-cp-or-def 98 } elseif {$state eq "get-cp-or-def"} { 99 # This means that 'def' cannot be a command prefix for 100 # DSL command. 101 if {$a eq "def"} { 102 # Short definition, name only, completed. 103 $self def $name 104 # We already have the first word of the next 105 # definition here, name is coming up next. 106 set state get-name 107 } else { 108 # Long definition, name + cp, completed. 109 $self def $name $a 110 # Must be followed by the next definition. 111 set state expect-def 112 } 113 } 114 } 115 if {$state eq "get-cp-or-def"} { 116 # Had a short definition last, now complete. 117 $self def $name 118 } elseif {$state eq "get-name"} { 119 # Incomplete definition at the end, bogus 120 return -code error "Incomplete definition at end, name missing." 121 } 122 return 123 } 124 125 # ### ### ### ######### ######### ######### 126 ## Processor state 127 ## Handle of the object incoming commands are dispatched to. 128 ## The currently active DSL code, i.e. word list. 129 130 variable unknown {} ; # command prefix invoked when 131 # encountering unknown command words. 132 variable engine {} ; # command 133 variable program {} ; # list (string) 134 variable arity -array {} ; # array (command name -> command arity) 135 variable cmd -array {} ; # array (command name -> method cmd prefix) 136 137 # ### ### ### ######### ######### ######### 138 ## API: DSL definition 139 140 ## DSL words map to method-prefixes, i.e. method names + fixed 141 ## arguments. We store them with the engine already added in front 142 ## to make them regular command prefixes. No 'mymethod' however, 143 ## that works only in engine code itself, not form the outside. 144 145 method def {name {mp {}}} { 146 if {$mp eq {}} { 147 # Derive method-prefix from DSL word. 148 set mp [list $name] 149 set m $name 150 set n 0 151 152 } else { 153 # No need to check for an empty method-prefix. That cannot 154 # happen, as it is diverted, see above. 155 156 set m [lindex $mp 0] 157 set n [expr {[llength $mp]-1}] 158 } 159 160 # Get method arguments, check for problems. 161 set a [$engine info args $m] 162 if {[lindex $a end] eq "args"} { 163 return -code error "Unable to handle Tcl varargs" 164 } 165 166 # The arity of the command is number of required arguments, 167 # with compensation for those already covered by the 168 # method-prefix. 169 170 set cmd($name) [linsert $mp 0 $engine] 171 set arity($name) [expr {[llength $a] - $n}] 172 return 173 } 174 175 method def/ {name ay {mp {}}} { 176 # Like def, except that the arity is specified 177 # explicitly. This is for methods with a variable number of 178 # arguments in their definition, possibly dependent on the 179 # fixed parts of the prefix. 180 181 if {$mp eq {}} { 182 # Derive method-prefix from DSL word. 183 set mp [list $name] 184 set m $name 185 186 } else { 187 # No need to check for an empty method-prefix. That cannot 188 # happen, as it is diverted, see above. 189 190 set m [lindex $mp 0] 191 } 192 193 # The arity of the command is specified by the caller. 194 195 set cmd($name) [linsert $mp 0 $engine] 196 set arity($name) $ay 197 return 198 } 199 200 method deflva {args} { $self defl $args ; return } 201 method defdva {args} { $self defd $args ; return } 202 method defl {names} { foreach n $names { $self def $n } ; return } 203 method defd {dict} { 204 if {[llength $dict]%2==1} { 205 return -code error "Expected a dictionary, got \"$dict\"" 206 } 207 foreach {name mp} $dict { 208 $self def $name $mp 209 } 210 return 211 } 212 213 method undefva {args} { $self undefl $args ; return } 214 method undefl {names} { 215 foreach name $names { 216 unset -nocomplain cmd($name) 217 unset -nocomplain arity($name) 218 } 219 return 220 } 221 222 # ### ### ### ######### ######### ######### 223 ## API: DSL execution 224 # 225 ## Consider moving the core implementation into procs, to reduce 226 ## call overhead 227 228 method run {args} { 229 return [$self runl $args] 230 } 231 232 method runl {alist} { 233 # Note: We are saving the current program and restore it 234 # afterwards, this handles the possibility that this is a 235 # recursive call into the dispatcher. 236 set saved $program 237 set program $alist 238 set r {} 239 while {[llength $program]} { 240 set r [$self run_next] 241 } 242 set program $saved 243 return $r 244 } 245 246 method run_next_while {accept} { 247 set r {} 248 while {[llength $program] && [struct::set contains $accept [$self peek]]} { 249 set r [$self run_next] 250 } 251 return $r 252 } 253 254 method run_next_until {reject} { 255 set r {} 256 while {[llength $program] && ![struct::set contains $reject [$self peek]]} { 257 set r [$self run_next] 258 } 259 return $r 260 } 261 262 method run_next_if {accept} { 263 set r {} 264 if {[llength $program] && [struct::set contains $accept [$self peek]]} { 265 set r [$self run_next] 266 } 267 return $r 268 } 269 270 method run_next_ifnot {reject} { 271 set r {} 272 if {[llength $program] && ![struct::set contains $reject [$self peek]]} { 273 set r [$self run_next] 274 } 275 return $r 276 } 277 278 method run_next {} { 279 # The first word in the list is the current command. Determine 280 # the number of its fixed arguments. This also checks command 281 # validity in general. 282 283 set c [lindex $program 0] 284 if {![info exists arity($c)]} { 285 # Invoke the unknown handler 286 return [uplevel #0 [linsert $unknown end $c]] 287 } 288 289 set n $arity($c) 290 set m $cmd($c) 291 292 # Take the fixed arguments from the input as well. 293 294 if {[llength $program] <= $n} { 295 return -code error -errorcode WIP \ 296 "Not enough arguments for command \"$c\"" 297 } 298 299 set cargs [lrange $program 1 $n] 300 incr n 301 302 # Remove the command to dispatch, and its fixed arguments from 303 # the program. This is done before the dispatch so that the 304 # command has access to the true current state of the input. 305 306 set program [lrange $program $n end] 307 308 # Now run the command with its arguments. Commands needing 309 # more than the declared fixed number of arguments are 310 # responsible for reading them from input via the method 311 # 'next' provided by the processor core. 312 313 # Note: m already has the engine at the front, it was stored 314 # that way, see 'def'. 315 316 if {![llength $cargs]} { 317 return [eval $m] 318 } else { 319 # Explanation: First linsert constructs 'linsert $m end {*}$cargs', 320 # which the inner eval transforms into '{*}$m {*}$cargs', which at 321 # last is run by the outer eval. 322 return [eval [eval [linsert $cargs 0 linsert $m end]]] 323 } 324 } 325 326 # ### ### ### ######### ######### ######### 327 ## Input manipulation 328 329 # Get next word from the input (shift) 330 method next {} { 331 set w [lindex $program 0] 332 set program [lrange $program 1 end] 333 return $w 334 } 335 336 # Peek at the next word in the input 337 method peek {} { 338 return [lindex $program 0] 339 } 340 341 # Retrieve the whole current program 342 method peekall {} { 343 return $program 344 } 345 346 # Replace the current programm 347 method replace {args} { 348 set program $args 349 return 350 } 351 method replacel {alist} { 352 set program $alist 353 return 354 } 355 356 # Insert words into the input stream. 357 method insert {at args} { 358 set program [eval [linsert $args 0 linsert $program $at]] 359 return 360 } 361 method insertl {at alist} { 362 set program [eval [linsert $alist 0 linsert $program $at]] 363 return 364 } 365 366 # <=> insert 0 367 method push {args} { 368 set program [eval [linsert $args 0 linsert $program 0]] 369 return 370 } 371 method pushl {alist} { 372 set program [eval [linsert $alist 0 linsert $program 0]] 373 return 374 } 375 376 # <=> insert end 377 method add {args} { 378 set program [eval [linsert $args 0 linsert $program end]] 379 return 380 } 381 method addl {alist} { 382 set program [eval [linsert $alist 0 linsert $program end]] 383 return 384 } 385 386 # ### ### ### ######### ######### ######### 387 388 method unknown {cmdprefix} { 389 set unknown $cmdprefix 390 return 391 } 392 393 method ErrorForUnknown {word} { 394 return -code error -errorcode WIP \ 395 "Unknown command \"$word\"" 396 } 397 398 ## 399 # ### ### ### ######### ######### ######### 400} 401 402# ### ### ### ######### ######### ######### 403## 404 405# Macro to declare the method of a component as proc. We use this 406# later to make access to a WIP processor simpler (no need to write 407# the component reference on our own). And no, this is not the same as 408# the standard delegation. Doing that simply replaces the component 409# name in the call with '$self'. We remove the need to have this 410# written in the call. 411 412snit::macro wip::methodasproc {var method suffix} { 413 proc $method$suffix {args} [string map [list @v@ $var @m@ $method] { 414 upvar 1 {@v@} dst 415 return [eval [linsert $args 0 $dst {@m@}]] 416 }] 417} 418 419# ### ### ### ######### ######### ######### 420## Ready 421 422# ### ### ### ######### ######### ######### 423## 424 425# Macro to install most of the boilerplate needed to setup and use a 426# WIP. The only thing left is to call the method 'wip_setup' in the 427# constructor of the class using WIP. This macro allows the creation 428# of multiple wip's, through custom suffices. 429 430snit::macro wip::dsl {{suffix {}}} { 431 if {$suffix ne ""} {set suffix _$suffix} 432 433 # Instance state, wip processor used to run the language 434 component mywip$suffix 435 436 # Standard method to create the processor component. The user has 437 # to manually add a call of this method to the constructor. 438 439 method wip${suffix}_setup {} [string map [list @@ $suffix] { 440 install {mywip@@} using ::wip "${selfns}::mywip@@" $self 441 }] 442 443 # Procedures for easy access to the processor methods, without 444 # having to use self and wip. I.e. special delegation. 445 446 foreach {p} { 447 add addl def undefva undefl 448 defd defdva defl deflva def/ 449 insert insertl replace replacel 450 push pushl run runl 451 next peek peekall run_next 452 run_next_until run_next_while 453 run_next_ifnot run_next_if 454 } { 455 wip::methodasproc mywip$suffix $p $suffix 456 } 457 return 458} 459 460# ### ### ### ######### ######### ######### 461## Ready 462 463package provide wip 1.2 464