1
2
3
4
5
6
7
8
9
10
11 table:
12 tmg: proc(name);
13
14 dcl name char(*);
15
16 dcl (in_pos,in_length,ll,out_pos,line_no,unique,
17 code,n,m,i,j) fixed bin,
18 (input_pt,output_pt,output_hold) ptr,
19 had_if bit(1),
20 first_time bit(1) int static init("1"b),
21 c char(1),
22 (vf,vg,sourcename,outputname) char(32) varying,
23 what char(8),
24 op_code char(12) varying,
25 line char(132) varying,
26 ent char(32),
27 (temppath,dir,wdir) char(168);
28
29 dcl sw(16) label local int static;
30
31 dcl (addr,divide,index,length,null,substr) builtin;
32
33 dcl n_special fixed bin int static init(16),
34 special(16) char(8) init("if","ifnot","flipto","jump","put",
35 "fetch","get_fx2","compile","cplalt","cplsave","load","add",
36 "switch","erase","bump","drop") int static;
37
38 dcl n_tests fixed bin int static init(11),
39 test(11) char(4) init("q2","q3","a2","a3","c2","c3","z2","z3",
40 "atm2", "atm3", "atm4") int static;
41
42 dcl n_switches fixed bin int static init(5),
43 switches(5) char(8) init("code","op","type1","type2","type3") int static;
44
45 dcl (com_err_,ioa_,ioa_$rsnp,ioa_$rsnpnnl) entry options(variable),
46 hcs_$initiate_count entry(char(*),char(*),char(*),fixed bin,
47 fixed bin,ptr,fixed bin),
48 expand_path_ entry(ptr,fixed bin,ptr,ptr,fixed bin),
49 get_wdir_ entry() returns(char(168)),
50 tssi_$get_segment entry(char(*),char(*),ptr,ptr,fixed bin),
51 tssi_$finish_segment entry(ptr,fixed bin(24),bit(36) aligned,ptr,fixed bin);
52
53 dcl ( nl init("
54 "),
55 quote init(""""),
56 star init("*"),
57 tab init(" "),
58 colon init(":")) char(1) int static;
59
60 dcl my_name char(3) int static init("tmg");
61
62 dcl input char(in_length) aligned based(input_pt);
63
64 dcl output char(262144) aligned based(output_pt);
65
66 dcl 1 output_structure aligned based(output_pt),
67 2 skip unaligned char(out_pos - 1),
68 2 output_line unaligned char(132);
69
70 if first_time
71 then do;
72 sw(1) = if;
73 sw(2) = ifnot;
74 sw(3) = flipto;
75 sw(4) = jump;
76 sw(5) = put;
77 sw(6) = fetch;
78 sw(7) = get_fx2;
79 sw(8) = compile;
80 sw(9) = cplalt;
81 sw(10) = cplsave;
82 sw(11) = load;
83 sw(12) = add;
84 sw(13) = switch;
85 sw(14) = erase;
86 sw(15) = bump;
87 sw(16) = drop;
88 first_time = "0"b;
89 end;
90
91 temppath = name;
92 call expand_path_(addr(temppath),length(name),addr(dir),addr(ent),code);
93
94 if code ^= 0
95 then do;
96 call com_err_(code,my_name,temppath);
97 return;
98 end;
99
100 n = index(ent," ");
101 if n = 0 then n = 33;
102 n = n - 1;
103
104 sourcename = substr(ent,1,n) || ".table";
105 outputname = substr(ent,1,n) || ".alm";
106
107 call hcs_$initiate_count(dir,(sourcename),"",in_length,1,input_pt,code);
108
109 if input_pt = null
110 then do;
111 call com_err_(code,my_name,sourcename);
112 return;
113 end;
114
115 if in_length = 0
116 then do;
117 call com_err_(0,my_name,"Zero length input.");
118 return;
119 end;
120
121 wdir = get_wdir_();
122 call tssi_$get_segment(wdir,(outputname),output_pt,output_hold,code);
123
124 if code ^= 0
125 then do;
126 out_err: call com_err_(code,my_name,outputname);
127 return;
128 end;
129
130 in_length = divide(in_length,9,17,0);
131 in_pos, out_pos, unique = 1;
132 line_no = 0;
133 had_if = "0"b;
134
135 find_nl: if in_pos >= in_length then goto done;
136
137 ll = index(substr(input,in_pos),nl);
138
139 if ll = 0 then goto done;
140 line_no = line_no + 1;
141
142 if ll = 1
143 then do;
144 in_pos = in_pos + 1;
145 put_nl: substr(output,out_pos,1) = nl;
146 out_pos = out_pos + 1;
147 goto find_nl;
148 end;
149
150 line = substr(input,in_pos,ll);
151 in_pos = in_pos + ll;
152
153 c = substr(line,1,1);
154
155 if c = quote
156 then do;
157 put_line: substr(output,out_pos,length(line)) = line;
158 out_pos = out_pos + length(line);
159 goto find_nl;
160 end;
161
162 if c = star
163 then do;
164
165 if ll = 3
166 then if substr(line,2,1) ^= star then goto star_err;
167 else do;
168 call ioa_$rsnp("^-zero^-0,128",output_line,n);
169 out_pos = out_pos + n;
170 goto put_lab;
171 end;
172
173 if ll = 2
174 then do;
175 put_lab: if had_if
176 then do;
177 call ioa_$rsnpnnl("L^d:",output_line,n,unique);
178 out_pos = out_pos + n;
179 unique = unique + 1;
180 had_if = "0"b;
181 end;
182
183 goto find_nl;
184 end;
185
186 star_err: call com_err_(0,my_name,"Illegal use of ""*"" in line # ^d:^/^a",line_no,line);
187 goto find_nl;
188 end;
189
190
191
192 labels: n = index(line,colon);
193
194 if n ^= 0
195 then do;
196 substr(output,out_pos,n) = substr(line,1,n);
197 out_pos = out_pos + n;
198
199 if n = length(line)-1 then goto put_nl;
200
201 line = substr(line,n+1);
202 goto labels;
203 end;
204
205
206
207
208 if substr(line,1,1) ^= tab
209 then do;
210 err: call com_err_(0,my_name,"Syntax error in line # ^d:^/^a",line_no,line);
211 goto find_nl;
212 end;
213
214
215
216 n = index(substr(line,2),tab);
217 if n = 0 then n = length(line) - 1;
218
219 op_code = substr(line,2,n-1);
220
221
222
223 do i = 1 to n_special;
224 if op_code = special(i) then goto found;
225 end;
226
227
228
229 goto put_line;
230
231
232
233 found: if n >= length(line) - 1 then vf = "";
234 else do;
235 m = index(substr(line,n+2),tab);
236 if m = 0 then m = length(line)-n-1;
237 vf = substr(line,n+2,m-1);
238 end;
239
240 goto sw(i);
241
242
243
244 if:
245 ifnot: do j = 1 to n_tests;
246 if vf = test(j) then goto if_ok;
247 end;
248
249 what = "Test";
250
251 err2: call com_err_(0,my_name,"^a ""^a"" not known, ""^a"" on line # ^d:^/^a",what,vf,op_code,
252 line_no,line);
253 goto find_nl;
254
255 if_ok: call ioa_$rsnpnnl("^-vfd^-18/L^d,9/^d,9/128+^d^a",output_line,n,unique,i,j,line);
256 had_if = "1"b;
257 goto inc;
258
259
260
261 switch: n = index(vf,",");
262 if n = 0
263 then do;
264 call com_err_(0,my_name,"Variable field error, switch on line # ^d:^/^a",line_no,line);
265 goto find_nl;
266 end;
267
268 vg = substr(vf,n+1);
269
270 do j = 1 to n_switches;
271 if vg = switches(j) then goto switch_ok;
272 end;
273
274 what = "Switch";
275 vf = vg;
276 goto err2;
277
278 switch_ok:
279 call ioa_$rsnpnnl("^-vfd^-18/^a,9/13,9/128+^d^a",output_line,n,substr(vf,1,n-1),
280 j,line);
281 goto inc;
282
283 drop:
284 bump:
285 erase:
286 flipto:
287 jump:
288 put:
289 fetch:
290 get_fx2:
291 compile:
292 cplalt:
293 cplsave:
294 load:
295 add: call ioa_$rsnpnnl("^-vfd^-18/^a,9/^d,9/128^a",output_line,n,vf,i,line);
296 inc: out_pos = out_pos + n;
297 goto find_nl;
298
299 done: call tssi_$finish_segment(output_pt,out_pos*9 - 9,"1010"b,output_hold,code);
300
301 if code ^= 0 then goto out_err;
302 end;