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