annotate keiko/iset.tcl @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
rev   line source
mike@0 1 #
mike@0 2 # iset.tcl
mike@0 3 #
mike@0 4 # This file is part of the Oxford Oberon-2 compiler
mike@0 5 # Copyright (c) 2006--2016 J. M. Spivey
mike@0 6 # All rights reserved
mike@0 7 #
mike@0 8 # Redistribution and use in source and binary forms, with or without
mike@0 9 # modification, are permitted provided that the following conditions are met:
mike@0 10 #
mike@0 11 # 1. Redistributions of source code must retain the above copyright notice,
mike@0 12 # this list of conditions and the following disclaimer.
mike@0 13 # 2. Redistributions in binary form must reproduce the above copyright notice,
mike@0 14 # this list of conditions and the following disclaimer in the documentation
mike@0 15 # and/or other materials provided with the distribution.
mike@0 16 # 3. The name of the author may not be used to endorse or promote products
mike@0 17 # derived from this software without specific prior written permission.
mike@0 18 #
mike@0 19 # THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
mike@0 20 # IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
mike@0 21 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
mike@0 22 # IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
mike@0 23 # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
mike@0 24 # PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
mike@0 25 # OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
mike@0 26 # WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
mike@0 27 # OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
mike@0 28 # ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
mike@0 29 #
mike@0 30
mike@0 31 # This workaround is needed with TCL 8.4.2 if output goes to an emacs
mike@0 32 # compilation buffer.
mike@0 33 fconfigure stdout -translation lf
mike@0 34 fconfigure stderr -translation lf
mike@0 35
mike@0 36 if {[llength $argv] != 4} {
mike@0 37 puts stderr "usage: iset input.iset header template interp"
mike@0 38 exit 1
mike@0 39 }
mike@0 40
mike@0 41 set srcdir [file dirname $argv0]
mike@0 42 source "$srcdir/util.tcl"
mike@0 43 source "$srcdir/iparse.tcl"
mike@0 44
mike@0 45 if {[file exists "config.tcl"]} {source "config.tcl"}
mike@0 46
mike@0 47 lsplit $argv infile hfile tfile ifile
mike@0 48
mike@0 49 # BUILD THE TRIE
mike@0 50
mike@0 51 # make_trie -- recursively build a trie for a set of strings
mike@0 52 proc make_trie {n strings} {
mike@0 53 global charcode first trie taken check ntrie
mike@0 54
mike@0 55 # Assume the strings agree on the first n characters
mike@0 56
mike@0 57 if {[llength $strings] == 0} {
mike@0 58 puts stderr "Empty trie!!!"
mike@0 59 return -9999
mike@0 60 }
mike@0 61
mike@0 62 # Set chars to the set of n'th characters of the strings
mike@0 63 set chars [remdups [lsort [map {nth_char $n} $strings]]]
mike@0 64 set c1 $charcode([lindex $chars 0])
mike@0 65
mike@0 66 # Find a place where a node for $chars will fit -- 0 for the root
mike@0 67 for {set q 0} {1} {incr q} {
mike@0 68 if {[info exists taken($q)]} continue
mike@0 69
mike@0 70 while {$ntrie <= $q+128} {
mike@0 71 set trie($ntrie) 0
mike@0 72 set check($ntrie) 128
mike@0 73 incr ntrie
mike@0 74 }
mike@0 75
mike@0 76 set ok 1
mike@0 77 foreach c $chars {
mike@0 78 set ix [expr {$q+$charcode($c)}]
mike@0 79 if {$check($ix) != 128} {
mike@0 80 set ok 0; break
mike@0 81 }
mike@0 82 }
mike@0 83
mike@0 84 if {$ok} break
mike@0 85 }
mike@0 86
mike@0 87 # Reserve the locations we will use by filling in check
mike@0 88 # (actual values in trie get filled in later)
mike@0 89 set taken($q) 1
mike@0 90
mike@0 91 foreach c $chars {
mike@0 92 set ix [expr {$q+$charcode($c)}]
mike@0 93 set check($ix) $charcode($c)
mike@0 94 }
mike@0 95
mike@0 96 # Recursively build sub-tries
mike@0 97 foreach c $chars {
mike@0 98 if {$c == ""} {
mike@0 99 set t [string range [lindex $strings 0] 0 [expr {$n-1}]]
mike@0 100 set trie($q) $first($t)
mike@0 101 set check($q) 0
mike@0 102 } else {
mike@0 103 set ix [expr {$q+$charcode($c)}]
mike@0 104 set subset [filter {nth_char_is $n $c} $strings]
mike@0 105 set trie($ix) [make_trie [expr {$n+1}] $subset]
mike@0 106 set check($ix) $charcode($c)
mike@0 107 }
mike@0 108 }
mike@0 109
mike@0 110 return $q
mike@0 111 }
mike@0 112
mike@0 113 proc has_templates {i} {
mike@0 114 global templates
mike@0 115 return [expr {[llength $templates($i)] > 0}]
mike@0 116 }
mike@0 117
mike@0 118 # Build a packed trie for the instructions
mike@0 119 proc build_trie {} {
mike@0 120 global ntrie instrs dirs
mike@0 121 set ntrie 0
mike@0 122 make_trie 0 [filter has_templates [concat $instrs $dirs]]
mike@0 123 }
mike@0 124
mike@0 125 proc dmp_trie {f q pfx} {
mike@0 126 global trie check ntrie
mike@0 127
mike@0 128 set sep ""
mike@0 129 if {$check($q) == 0} {
mike@0 130 puts $f [format "--> %d" $trie($q)]
mike@0 131 set sep $pfx
mike@0 132 }
mike@0 133 set nchild 0
mike@0 134 for {set c 1} {$c < 128} {incr c} {
mike@0 135 set i [expr {$q+$c}]
mike@0 136 if {$check($i) == $c} {
mike@0 137 set char($nchild) $c
mike@0 138 set son($nchild) $trie($i)
mike@0 139 incr nchild
mike@0 140 }
mike@0 141 }
mike@0 142
mike@0 143 for {set j 0} {$j < $nchild} {incr j} {
mike@0 144 puts -nonewline $f [format "%s\[%c\] %3d " $sep $char($j) $son($j)]
mike@0 145 if {$j+1 < $nchild} {
mike@0 146 set slug " | "
mike@0 147 } else {
mike@0 148 set slug " "
mike@0 149 }
mike@0 150 dmp_trie $f $son($j) "$pfx$slug"
mike@0 151 set sep $pfx
mike@0 152 }
mike@0 153 }
mike@0 154
mike@0 155
mike@0 156 # GENERATE HEADER FILE
mike@0 157
mike@0 158 proc gen_header {name} {
mike@0 159 global ntempl maxargs instrs instrno dirs dirno ops action ntrie \
mike@0 160 expand opcode ncodes
mike@0 161
mike@0 162 set f [open $name "w"]
mike@0 163 puts $f "/* Header file -- generated by iset.tcl */"
mike@0 164 puts $f ""
mike@0 165 puts $f "#define NTEMPLATES $ntempl"
mike@0 166 puts $f "#define NTRIE $ntrie"
mike@0 167 puts $f "#define MAXARGS $maxargs"
mike@0 168 puts $f ""
mike@0 169
mike@0 170 puts $f "#define __INSTRS__(i) \\"
mike@0 171 puts -nonewline $f " i(ILLEGAL)"
mike@0 172 foreach i $instrs {
mike@0 173 set m [list [csym "" $i]]
mike@0 174 if {[info exists expand($i)]} {
mike@0 175 foreach x $expand($i) {
mike@0 176 if {[regexp {^(.*) \$a$} $x _ y]} {
mike@0 177 lappend m "[csym I $y]|IARG"
mike@0 178 } elseif {[regexp {^(.*) (-?[0-9]*)$} $x _ y z]} {
mike@0 179 lappend m "[csym I $y]|ICON" $z
mike@0 180 } else {
mike@0 181 lappend m "[csym I $x]"
mike@0 182 }
mike@0 183 }
mike@0 184 }
mike@0 185 puts -nonewline $f \
mike@0 186 " \\\n i([join $m ", "])"
mike@0 187 }
mike@0 188 puts $f ""
mike@0 189 puts $f ""
mike@0 190 puts $f "#define __i1__(sym, ...) I_##sym,"
mike@0 191 puts $f "enum { __INSTRS__(__i1__) };"
mike@0 192 puts $f ""
mike@0 193
mike@0 194 puts $f "#define __DIRS__(d) \\"
mike@0 195 puts -nonewline $f " d(ILLEGAL)"
mike@0 196 foreach d $dirs {
mike@0 197 puts -nonewline $f " \\\n d([csym "" $d])"
mike@0 198 }
mike@0 199 puts $f ""
mike@0 200 puts $f ""
mike@0 201 puts $f "#define __d1__(sym) D_##sym,"
mike@0 202 puts $f "enum { __DIRS__(__d1__) };"
mike@0 203 puts $f ""
mike@0 204
mike@0 205 # Not an enum, because bases are not contiguous!
mike@0 206 puts $f "#define K_ILLEGAL 0"
mike@0 207 foreach op $ops {
mike@0 208 with $action($op) {base count length inst key act args} {
mike@0 209 puts $f "#define [csym K $op] $base"
mike@0 210 }
mike@0 211 }
mike@0 212 puts $f ""
mike@0 213
mike@0 214 puts -nonewline $f "#define __OPCODES__(o)"
mike@0 215 for {set i 0} {$i < $ncodes} {incr i} {
mike@0 216 with $opcode($i) {op inst patt arg len} {
mike@0 217 puts -nonewline $f \
mike@0 218 " \\\n o($op, $inst, \"$patt\", $arg, $len)"
mike@0 219 }
mike@0 220 }
mike@0 221 puts $f ""
mike@0 222
mike@0 223 close $f
mike@0 224 }
mike@0 225
mike@0 226 # GENERATE TEMPLATE FILE
mike@0 227
mike@0 228 # make_code -- assemble equivalent code
mike@0 229 proc make_code {op} {
mike@0 230 global ops dirs status
mike@0 231
mike@0 232 if {$op == "NOP"} {
mike@0 233 return {}
mike@0 234 } elseif {[lmember $op $ops]} {
mike@0 235 return [csym K $op]
mike@0 236 } elseif {[lmember $op $dirs]} {
mike@0 237 return [csym D $op]
mike@0 238 } else {
mike@0 239 puts stderr "Code $op does not exist"
mike@0 240 set status 1
mike@0 241 }
mike@0 242 }
mike@0 243
mike@0 244 proc quote {s} {return "\"$s\""}
mike@0 245
mike@0 246 proc gen_template {name} {
mike@0 247 global templates instrs dirs first ntrie trie check macro
mike@0 248
mike@0 249 set f [open $name "w"]
mike@0 250 puts $f "/* Template file -- generated by iset.tcl */"
mike@0 251 puts $f ""
mike@0 252 puts $f "#include \"oblink.h\""
mike@0 253 puts $f "#include \"keiko.h\""
mike@0 254 puts $f ""
mike@0 255
mike@0 256 set nt 0
mike@0 257 set fmt "{%-12s %-7s%3d, %2d, %2d, %2d, %2d, %s, {%s}},"
mike@0 258 puts $f "struct _template templates\[NTEMPLATES\] = {"
mike@0 259 foreach inst [concat $instrs $dirs] {
mike@0 260 set first($inst) $nt
mike@0 261 foreach templ $templates($inst) {
mike@0 262 with $templ {patt bounds op argsz} {
mike@0 263 with $bounds {lo hi step} {
mike@0 264 if {$nt == $first($inst)} {
mike@0 265 set icode "\"$inst\""
mike@0 266 } else {
mike@0 267 set icode " NULL"
mike@0 268 }
mike@0 269 if {[info exists macro($op)]} {
mike@0 270 set maclines [map quote $macro($op)]
mike@0 271 puts $f \
mike@0 272 [format $fmt "$icode," "\"$patt\"," \
mike@0 273 $lo $hi $step 0 0 0 [join $maclines ", "]]
mike@0 274 } else {
mike@0 275 if {$op == "NOP"} {
mike@0 276 set n 0; set c 0
mike@0 277 } else {
mike@0 278 set n 1; set c [make_code $op]
mike@0 279 }
mike@0 280 set len [expr {$argsz >= 0 ? $n + $argsz : $argsz}]
mike@0 281 puts $f \
mike@0 282 [format $fmt "$icode," "\"$patt\"," \
mike@0 283 $lo $hi $step $len $n $c ""]
mike@0 284 }
mike@0 285 }
mike@0 286 }
mike@0 287 incr nt
mike@0 288 }
mike@0 289 }
mike@0 290 puts $f "};";
mike@0 291 puts $f "";
mike@0 292
mike@0 293 build_trie
mike@0 294
mike@0 295 puts $f "/*"
mike@0 296 dmp_trie $f 0 ""
mike@0 297 puts $f "*/"
mike@0 298 puts $f ""
mike@0 299
mike@0 300 puts $f "short templ_trie\[NTRIE\] = {"
mike@0 301 for {set i 0} {$i < $ntrie} {incr i} {
mike@0 302 if {$i > 0 && $i % 10 == 0} {puts $f ""}
mike@0 303 puts -nonewline $f [format "%4d, " $trie($i)]
mike@0 304 }
mike@0 305 puts $f "\n};"
mike@0 306 puts $f "";
mike@0 307 puts $f "uchar templ_check\[NTRIE\] = {"
mike@0 308 for {set i 0} {$i < $ntrie} {incr i} {
mike@0 309 if {$i > 0 && $i % 10 == 0} {puts $f ""}
mike@0 310 if {$check($i) >= 32 && $check($i) < 128} {
mike@0 311 puts -nonewline $f [format " '%c', " $check($i)]
mike@0 312 } else {
mike@0 313 puts -nonewline $f [format "%4d, " $check($i)]
mike@0 314 }
mike@0 315 }
mike@0 316 puts $f "\n};"
mike@0 317 close $f
mike@0 318 }
mike@0 319
mike@0 320 # GENERATE INTERPRETER
mike@0 321
mike@0 322 proc copy_some {f} {
mike@0 323 global skelf
mike@0 324
mike@0 325 while {[gets $skelf line] >= 0} {
mike@0 326 if {[regexp {^\$\$} $line]} break
mike@0 327 puts $f $line
mike@0 328 }
mike@0 329 }
mike@0 330
mike@0 331 proc make_body {key action argv} {
mike@0 332 global err_op
mike@0 333
mike@0 334 set body $action
mike@0 335
mike@0 336 for {set i 0} {$i < [llength $argv]} {incr i} {
mike@0 337 set formal [string index "abcd" $i]
mike@0 338 regsub -all "\\\$$formal" $body [lindex $argv $i] body
mike@0 339 }
mike@0 340
mike@0 341 regsub -all {\$s} $body "sp" body
mike@0 342 regexp {\.(.)} $key _ suffix
mike@0 343
mike@0 344 switch -glob -- $key {
mike@0 345 B.d {
mike@0 346 # Double from two doubles
mike@0 347 regsub -all {\$1\.d} $body {getdbl(\&sp[0])} body
mike@0 348 regsub -all {\$2\.d} $body {getdbl(\&sp[-2])} body
mike@0 349 return "sp += 2; putdbl(&sp\[0\], $body);"
mike@0 350 }
mike@0 351 B.?dd {
mike@0 352 # Value from two doubles
mike@0 353 regsub -all {\$1\.d} $body {getdbl(\&sp[-1])} body
mike@0 354 regsub -all {\$2\.d} $body {getdbl(\&sp[-3])} body
mike@0 355 return "sp += 3; sp\[0\].$suffix = $body;"
mike@0 356 }
mike@0 357 B.d?? {
mike@0 358 # Double from two values
mike@0 359 regsub -all {\$1} $body {sp[1]} body
mike@0 360 regsub -all {\$2} $body {sp[0]} body
mike@0 361 return "putdbl(&sp\[0\], $body);"
mike@0 362 }
mike@0 363 B.q {
mike@0 364 # Long from two longs
mike@0 365 regsub -all {\$1\.q} $body {getlong(\&sp[0])} body
mike@0 366 regsub -all {\$2\.q} $body {getlong(\&sp[-2])} body
mike@0 367 return "sp += 2; putlong(&sp\[0\], $body);"
mike@0 368 }
mike@0 369 B.?qq {
mike@0 370 # Value from two longs
mike@0 371 regsub -all {\$1\.q} $body {getlong(\&sp[-1])} body
mike@0 372 regsub -all {\$2\.q} $body {getlong(\&sp[-3])} body
mike@0 373 return "sp += 3; sp\[0\].$suffix = $body;"
mike@0 374 }
mike@0 375 B.q?? {
mike@0 376 # Long from two values
mike@0 377 regsub -all {\$1} $body {sp[1]} body
mike@0 378 regsub -all {\$2} $body {sp[0]} body
mike@0 379 return "putlong(&sp\[0\], $body);"
mike@0 380 }
mike@0 381 B.x {
mike@0 382 regsub -all {\$1} $body {sp[0]} body
mike@0 383 regsub -all {\$2} $body {sp[-1]} body
mike@0 384 return "sp++; sp\[0\].a = address($body);"
mike@0 385 }
mike@0 386 B.? {
mike@0 387 regsub -all {\$1} $body {sp[0]} body
mike@0 388 regsub -all {\$2} $body {sp[-1]} body
mike@0 389 return "sp++; sp\[0\].$suffix = $body;"
mike@0 390 }
mike@0 391 M.dq {
mike@0 392 regsub -all {\$1\.q} $body {getlong(\&sp[0])} body
mike@0 393 return "putdbl(&sp\[0\], $body);"
mike@0 394 }
mike@0 395 M.qd {
mike@0 396 regsub -all {\$1\.d} $body {getdbl(\&sp[0])} body
mike@0 397 return "putlong(&sp\[0\], $body);"
mike@0 398 }
mike@0 399 M.d {
mike@0 400 regsub -all {\$1\.d} $body {getdbl(\&sp[0])} body
mike@0 401 return "putdbl(&sp\[0\], $body);"
mike@0 402 }
mike@0 403 M.d? {
mike@0 404 # Double from value
mike@0 405 regsub -all {\$1} $body {sp[1]} body
mike@0 406 return "sp--; putdbl(&sp\[0\], $body);"
mike@0 407 }
mike@0 408 M.?d {
mike@0 409 # Value from double
mike@0 410 regsub -all {\$1\.d} $body {getdbl(\&sp[-1])} body
mike@0 411 return "sp++; sp\[0\].$suffix = $body;"
mike@0 412 }
mike@0 413 M.q {
mike@0 414 regsub -all {\$1\.q} $body {getlong(\&sp[0])} body
mike@0 415 return "putlong(&sp\[0\], $body);"
mike@0 416 }
mike@0 417 M.q? {
mike@0 418 # Long from value
mike@0 419 regsub -all {\$1} $body {sp[1]} body
mike@0 420 return "sp--; putlong(&sp\[0\], $body);"
mike@0 421 }
mike@0 422 M.?q {
mike@0 423 # Value from long
mike@0 424 regsub -all {\$1\.q} $body {getlong(\&sp[-1])} body
mike@0 425 return "sp++; sp\[0\].$suffix = $body;"
mike@0 426 }
mike@0 427 M.x {
mike@0 428 regsub -all {\$1} $body {sp[0]} body
mike@0 429 return "sp\[0\].a = address($body);"
mike@0 430 }
mike@0 431 M.? {
mike@0 432 regsub -all {\$1} $body {sp[0]} body
mike@0 433 return "sp\[0\].$suffix = $body;"
mike@0 434 }
mike@0 435 V.d {
mike@0 436 return "sp -= 2; putdbl(&sp\[0\], $body);"
mike@0 437 }
mike@0 438 V.q {
mike@0 439 return "sp -= 2; putlong(&sp\[0\], $body);"
mike@0 440 }
mike@0 441 V.x {
mike@0 442 return "sp--; sp\[0\].a = address($body);"
mike@0 443 }
mike@0 444 V.? {
mike@0 445 return "sp--; sp\[0\].$suffix = $body;"
mike@0 446 }
mike@0 447 S0 {
mike@0 448 return "{ $body }"
mike@0 449 }
mike@0 450 S[123] {
mike@0 451 regexp {S(.)} $key _ x
mike@0 452 for {set i 1} {$i < $x} {incr i} {
mike@0 453 regsub -all "\\\$$i" $body "sp\[-$i\]" body
mike@0 454 }
mike@0 455 regsub -all "\\\$$x" $body "sp\[-$x\]" body
mike@0 456 return "sp += $x; { $body }"
mike@0 457 }
mike@0 458 S1d {
mike@0 459 regsub -all {\$1\.d} $body {getdbl(\&sp[-2])} body
mike@0 460 return "sp += 2; { $body }"
mike@0 461 }
mike@0 462 S2d? {
mike@0 463 regsub -all {\$1\.d} $body {getdbl(\&sp[-2])} body
mike@0 464 regsub -all {\$2} $body {sp[-3]} body
mike@0 465 return "sp += 3; { $body }"
mike@0 466 }
mike@0 467 S3d?? {
mike@0 468 regsub -all {\$1\.d} $body {getdbl(\&sp[-2])} body
mike@0 469 regsub -all {\$2} $body {sp[-3]} body
mike@0 470 regsub -all {\$3} $body {sp[-4]} body
mike@0 471 return "sp += 4; { $body }"
mike@0 472 }
mike@0 473 S1q {
mike@0 474 regsub -all {\$1\.q} $body {getlong(\&sp[-2])} body
mike@0 475 return "sp += 2; { $body }"
mike@0 476 }
mike@0 477 S2q? {
mike@0 478 regsub -all {\$1\.q} $body {getlong(\&sp[-2])} body
mike@0 479 regsub -all {\$2} $body {sp[-3]} body
mike@0 480 return "sp += 3; { $body }"
mike@0 481 }
mike@0 482 S3q?? {
mike@0 483 regsub -all {\$1\.q} $body {getlong(\&sp[-2])} body
mike@0 484 regsub -all {\$2} $body {sp[-3]} body
mike@0 485 regsub -all {\$3} $body {sp[-4]} body
mike@0 486 return "sp += 4; { $body }"
mike@0 487 }
mike@0 488 T2 {
mike@0 489 regsub -all {\$1} $body {sp[0]} body
mike@0 490 regsub -all {\$2} $body {sp[-1]} body
mike@0 491 return "sp++; { $body }"
mike@0 492 }
mike@0 493 default {
mike@0 494 error "Bad key $key for $err_op"
mike@0 495 }
mike@0 496 }
mike@0 497 }
mike@0 498
mike@0 499 proc gen_interp {name sname} {
mike@0 500 global skelf ncodes opcode defs copy ops action input err_op
mike@0 501
mike@0 502 set f [open $name "w"]
mike@0 503 set skelf [open $sname "r"]
mike@0 504
mike@0 505 puts $f "/* Instruction interpreter -- generated by iset.tcl */"
mike@0 506 puts $f ""
mike@0 507
mike@0 508 copy_some $f
mike@0 509
mike@0 510 # macros used in action code
mike@0 511 puts $f $defs
mike@0 512
mike@0 513 copy_some $f
mike@0 514
mike@0 515 # jtable array
mike@0 516 for {set i 0} {$i < 256} {incr i} {
mike@0 517 if {$i < $ncodes} {
mike@0 518 with $opcode($i) {op inst patt arg len} {
mike@0 519 puts $f " &&lbl_$op,"
mike@0 520 }
mike@0 521 } else {
mike@0 522 puts $f " &&lbl_ILLEGAL,"
mike@0 523 }
mike@0 524 }
mike@0 525
mike@0 526 copy_some $f
mike@0 527
mike@0 528 # action code
mike@0 529 foreach op $ops {
mike@0 530 set err_op $op
mike@0 531 with $action($op) {base count length inst key act argv} {
mike@0 532 set act [make_body $key $act $argv]
mike@0 533 puts $f " ACTION($op)"
mike@0 534 for {set j 1} {$j < $count} {incr j} {
mike@0 535 puts $f " ALSO($op+$j)"
mike@0 536 }
mike@0 537 puts $f " pc = pc0 + $length;"
mike@0 538 puts $f " $act"
mike@0 539 puts $f " NEXT;"
mike@0 540 puts $f ""
mike@0 541 }
mike@0 542 }
mike@0 543
mike@0 544 copy_some $f
mike@0 545
mike@0 546 close $skelf
mike@0 547 close $f
mike@0 548 }
mike@0 549
mike@0 550
mike@0 551 # MAIN PROGRAM
mike@0 552
mike@0 553 readfile $infile
mike@0 554
mike@0 555 if {$status != 0} {exit $status}
mike@0 556
mike@0 557 gen_template $tfile
mike@0 558 gen_interp $ifile $srcdir/iskel.c
mike@0 559 gen_header $hfile
mike@0 560
mike@0 561 # Print statistics
mike@0 562 puts "Instr Count Opcodes"
mike@0 563 set fmt "%-10s %3d %3d"
mike@0 564 set count(0) 0;
mike@0 565 set count(1) 1; # Allow for ILLEGAL
mike@0 566 set count(2) 0
mike@0 567 foreach inst $instrs {
mike@0 568 if {$opcount($inst) <= 2} {
mike@0 569 incr count($opcount($inst))
mike@0 570 } else {
mike@0 571 puts [format $fmt $inst 1 $opcount($inst)]
mike@0 572 }
mike@0 573 }
mike@0 574 puts [format $fmt "singles" $count(1) $count(1)]
mike@0 575 puts [format $fmt "doubles" $count(2) [expr {2 * $count(2)}]]
mike@0 576 puts [format $fmt "Total" $ninstr $ncodes]
mike@0 577
mike@0 578 if {$ncodes > 256} {set status 1}
mike@0 579
mike@0 580 exit $status