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