1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  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           /* check for labels */
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           /* having eliminated all labels, the first character
206              on the line should now be a tab */
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           /* pickup op code */
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           /* check for one of our special pseudo-ops */
222 
223           do i = 1 to n_special;
224                if op_code = special(i) then goto found;
225                end;
226 
227           /* not special op code */
228 
229           goto put_line;
230 
231           /* have pseudo-op, get variable field */
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           /* conditional, check to make sure vf specifies legal test */
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           /* switch, extract code from variable field */
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;