1
2
3
4
5
6
7
8
9
10
11 db_assign: proc (il, lin, ill, data_ptr, sntp, db_mc_ptr, old_type, a_cur_size, a_old_size, print_mode, dec_default);
12
13 %include db_ext_stat_;
14
15 dcl db_mc_ptr ptr;
16 dcl il char (132) aligned,
17 (lin, ill) fixed bin,
18 print_mode fixed bin,
19 data_ptr ptr;
20
21 dcl a_cur_size fixed bin;
22 dcl cur_size fixed bin;
23 dcl a_old_size fixed bin;
24 dcl old_type fixed bin;
25 dcl old_size fixed bin;
26 dcl new_size fixed bin;
27 dcl last_char fixed bin;
28
29 dcl
30 com_err_ entry options (variable),
31 cu_$level_get entry returns (fixed bin),
32 db_get_count ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin),
33 db_get_count$dec ext entry (char (132) aligned, fixed bin, fixed bin) returns (fixed bin),
34 db_regs$get ext entry (ptr, char (4), bit (72), fixed bin),
35 db_sym ext entry (char (72) var, ptr, ptr, fixed bin, fixed bin, char (1) aligned,
36 char (*) aligned, fixed bin, fixed bin, fixed bin),
37 print_text_$format ext entry (ptr, char (*) var),
38 hcs_$add_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)),
39 hcs_$delete_acl_entries entry (char (*)aligned, char (*)aligned, ptr, fixed, fixed bin (35)),
40 get_group_id_ entry returns (char (32) aligned),
41 hcs_$fs_get_mode ext entry (ptr, fixed bin (5), fixed bin (35)),
42 ioa_$ioa_stream ext entry options (variable),
43 db_parse_arg ext entry (char (132) aligned, fixed bin, fixed bin, ptr, fixed bin, fixed bin);
44
45 dcl fix_bit entry (bit (*) aligned, fixed bin) returns (fixed bin);
46 dcl fix_bit$double entry (bit (*) aligned, fixed bin) returns (fixed bin (71));
47
48 dcl
49 access_ok fixed bin (1),
50 base fixed bin,
51 code fixed bin,
52 code35 fixed bin (35),
53 emode fixed bin (5),
54 off fixed bin,
55 offset fixed bin,
56 op fixed bin,
57 rb (0:2) fixed bin,
58 rep_count fixed bin,
59 size fixed bin,
60 max_size fixed bin,
61 tag fixed bin,
62 type fixed bin,
63 (i, j, k) fixed bin;
64 dcl index_start_no fixed bin;
65
66 dcl 1 delete_acl aligned,
67 2 access_name char (32),
68 2 status_code fixed bin (35);
69 dcl 1 segment_acl aligned,
70 2 access_name char (32),
71 2 modes bit (36) init ("111000000000000000000000000000000000"b),
72 2 zero_pad bit (36) init ("0"b),
73 2 status_code fixed bin (35);
74
75 dcl (old_sign, new_sign) fixed bin;
76
77 dcl pad_bits fixed bin;
78 dcl off_inc fixed bin;
79 dcl (old_bit_off, new_bit_off) fixed bin;
80
81 dcl fword fixed bin based;
82
83 dcl flword float bin based;
84
85 dcl two_words bit (72) based;
86
87 dcl words (2) bit (36) aligned based;
88
89 dcl tw_flag fixed bin init (0);
90
91 dcl reg_name char (4);
92
93 dcl len_ptr ptr;
94
95 dcl dp ptr,
96 tp ptr,
97 tem (17) ptr,
98 temp ptr,
99
100 bptr ptr based;
101 dcl packed_ptr ptr unal based;
102
103 dcl (old_ptr, new_ptr) ptr;
104 dcl ones bit (72) int static init ((72)"1"b);
105
106 dcl TOO_BIG fixed bin int static init(1);
107 dcl BAD_SYNTAX fixed bin int static init(2);
108 dcl MISS_PAREN fixed bin int static init(3);
109 dcl BAD_PR fixed bin int static init(4);
110 dcl NO_REG fixed bin int static init(5);
111 dcl NO_SYM fixed bin int static init(6);
112 dcl OPCODE fixed bin int static init(7);
113 dcl TAG fixed bin int static init(8);
114 dcl SYNTAX fixed bin int static init(9);
115 dcl BAD_REP fixed bin int static init(10);
116 dcl mess (10) char(40) var int static init (
117 "Value too large",
118 "Bad syntax in instruction input",
119 "Missing "")""",
120 "Invalid pointer register",
121 "Register name missing",
122 "Variable not defined",
123 "Bad opcode",
124 "Bad tag",
125 "Syntax error scanning input",
126 "Illegal repetition factor");
127 dcl sign_bit bit (1) unal based;
128 dcl dec_default bit (1) unal;
129
130
131 dcl (old_word, new_word) bit (36) aligned;
132 dcl (old_double, new_double) fixed bin (71);
133
134 dcl control char (8) aligned;
135
136 dcl mode char (1) aligned,
137 old_str char (old_size) based (dp),
138 str char (size) based (tp),
139 repstr char (size*rep_count) based,
140 old_bits bit (old_size) based (dp),
141 new_bits bit (size) based (tp),
142 chars (0:10000) char (1) unal based,
143 bitarr (0:10000) bit (1) unal based,
144 sym_name char (72) aligned,
145 opcode6 char (6) aligned,
146 c2 char (2) aligned,
147 c4 char (4) aligned,
148 (name1, name2) char (72) var,
149 db_sym_name char (72) var,
150 (type_char, mode_char) char (1) aligned;
151
152
153
154
155
156 dcl old_pr_names (0:7) char (2) int static init
157 ("ap", "ab", "bp", "bb", "lp", "lb", "sp", "sb");
158
159 dcl conversion condition;
160 dcl underflow condition;
161
162
163 dcl ffdouble fixed bin (71) based;
164 dcl 1 ff aligned based,
165 2 (w0, w1, w2, w3, w4, w5, w6, w7) fixed bin;
166
167 dcl (addr, addrel, bit, char, fixed, index, max, min, mod, null, substr, unspec, rel) builtin;
168 dcl (abs, binary, divide, search, verify) builtin;
169
170 %include db_snt;
171
172 %include db_inst;
173
174 %include its;
175
176
177
178 dcl 1 op_mnemonic_$op_mnemonic (0:1023) ext static aligned,
179 2 opcode char (6) unal,
180 2 dtype fixed bin (2) unal,
181
182 2 num_desc fixed bin (5) unal,
183 2 num_words fixed bin (8) unal;
184
185 %include db_data_map;
186
187
188 temp = addr (tem);
189 dp = data_ptr;
190 cur_size = a_cur_size;
191 old_size = a_old_size;
192
193
194
195
196 call hcs_$fs_get_mode (dp, emode, code35);
197 if code35 = 0 then do;
198 if bit (emode, 5) & "00010"b then access_ok = 1;
199 else do;
200 access_ok = 0;
201 segment_acl.access_name = get_group_id_ ();
202 call hcs_$add_acl_entries (snt.dir_name, snt.ent_name, addr (segment_acl), 1, code35);
203 end;
204 end;
205 if code35 ^= 0 then do;
206 call com_err_ (code35, "debug", "Cannot change ^p", dp);
207 return;
208 end;
209
210 if print_mode ^= 0 then
211 call ioa_$ioa_stream (debug_output, "Changing ^p", dp);
212
213 last_char = ill -1;
214 do while (get_char (lin));
215
216 rep_count = 1;
217
218 if mode = "(" then call get_rep_count (rep_count);
219 if mode = "(" then call get_instruction;
220 else if mode = "$" then do;
221 dec_default = "0"b;
222 i = search (substr (il, lin, ill-lin+1), " ;");
223 if i = 0 then i = ill;
224 else i = lin + i -1;
225 if i-lin-1 < 1 then call error (NO_REG, "");
226 sym_name = substr (il, lin+1, i-lin-1);
227 lin = i;
228 reg_name = substr (sym_name, 1, 4);
229 type = 1;
230 size = 36;
231 call db_regs$get (db_mc_ptr, reg_name, temp -> two_words, print_mode);
232 if reg_name = "aq" then size = 72;
233 do i = 0 to 7;
234 if reg_name = db_data$names (i) then do;
235 size = 72;
236 type = 13;
237 end;
238 end;
239 if size ^= 72 then tp = addrel (temp, 1);
240 else tp = temp;
241
242 call store_value;
243
244 end;
245
246 else do;
247 index_start_no = lin;
248 type = 0;
249 if ^dec_default then do;
250 temp -> fword = db_get_count (il, lin, i);
251 if i > lin then if index (", ;
252 ", substr (il, i, 1)) ^= 0 then do;
253 type = 1;
254 lin = i;
255 end;
256 end;
257
258 if type = 0 then call db_parse_arg (il, lin, ill, temp, type, size);
259 tp = temp;
260
261 if type = -1 then goto reset;
262
263 if type = 1 | type = 3 then size = 36;
264 if type = 13 then size = 72;
265
266 if type = 0 then do;
267 db_sym_name = str;
268 call db_sym (db_sym_name, sntp, tp, offset, type, type_char, mode_char, size, max_size, code);
269 if code ^= 0 then call error (NO_SYM, (name1));
270 end;
271
272 call store_value;
273
274 end;
275 end;
276
277 reset:
278 if access_ok = 0 then call hcs_$delete_acl_entries (snt.dir_name, snt.ent_name, addr (segment_acl), 1, code35);
279 return;
280
281
282
283 bump: proc;
284
285
286
287
288
289 off_inc = divide (old_size, 36, 17, 0);
290 old_bit_off = fixed (addr (dp) -> its.bit_offset, 6);
291
292 new_bit_off = old_bit_off + mod (old_size, 36);
293 if new_bit_off > 36 then do;
294 new_bit_off = new_bit_off - 36;
295 off_inc = off_inc + 1;
296 end;
297
298 dp = addrel (dp, off_inc);
299
300 if new_bit_off ^= 0 then
301 addr (dp) -> its.bit_offset = bit (fixed (new_bit_off, 6), 6);
302
303 rep_count = rep_count - 1;
304 return;
305 end bump;
306
307
308
309
310
311
312
313 error: proc (mess_code, illegal_string);
314
315 dcl mess_code fixed bin;
316 dcl illegal_string char (*) aligned;
317
318 call ioa_$ioa_stream (debug_output, "^a ^a", mess (mess_code), illegal_string);
319 goto reset;
320
321 end error;
322
323 ^L
324
325
326
327
328
329
330 get_char: proc (index) returns (bit (1));
331
332 dcl index fixed bin;
333 dcl i fixed;
334
335 lin = index;
336 if lin <= last_char then do;
337 i = verify (substr (il, lin, last_char - lin + 1), " ");
338 if i > 0 then do;
339 lin = lin + i -1;
340 mode = substr (il, lin, 1);
341 if mode ^= ";" then return ("1"b);
342 end;
343 else lin = last_char + 1;
344 end;
345
346 return ("0"b);
347
348 end get_char;
349
350 ^L
351
352
353
354
355
356
357
358 get_instruction: proc;
359
360 if ^get_char (lin + 1) then call error (MISS_PAREN, "");
361 j = search (substr (il, lin, last_char - lin + 1), " )");
362 if j = 0 then call error (MISS_PAREN, "");
363 opcode6 = substr (il, lin, j -1);
364 lin = lin + j -1;
365 op = -1;
366 do i = 0 to 1023 while (op = -1);
367 if opcode6 = op_mnemonic_$op_mnemonic (i).opcode then op = i;
368 end;
369 if op = -1 then call error (OPCODE, opcode6);
370
371 if ^get_char (lin) then call error (SYNTAX, "");
372 base = -1;
373
374 if substr (il, lin+3, 1) = "|" then do;
375 if substr (il, lin, 2) ^= "pr" then call error (BAD_PR, "");
376 lin = lin + 2;
377 base = index ("01234567", substr (il, lin, 1)) -1;
378 if base = -1 then call error (BAD_PR, "");
379 lin = lin + 2;
380 end;
381
382 else if substr (il, lin+2, 1) = "|" then do;
383 c2 = substr (il, lin, 2);
384 lin = lin + 3;
385 base = -1;
386 do i = 0 to 7 while (base = -1);
387 if c2 = old_pr_names (i) then base = i;
388 end;
389 if base = -1 then call error (BAD_PR, "");
390 end;
391
392 j = lin;
393 off = db_get_count (il, lin, lin);
394 if j = lin then if substr (il, lin, 1) = ")" then off = 0;
395 else call error (SYNTAX, "");
396 tag = 0;
397 if substr (il, lin, 1) = "," then do;
398 j = index (substr (il, lin+1, 4), ")");
399 if j = 0 then call error (MISS_PAREN, "");
400 c4 = substr (il, lin, j);
401 lin = lin+j+1;
402
403 tag = -1;
404 do i = 0 to 63 while (tag = -1);
405 if db_data$tags (i) = c4 then tag = i;
406 end;
407 if tag = -1 then call error (TAG, c4);
408 end;
409 else do;
410 if ^get_char (lin) then call error (MISS_PAREN, "");
411 if mode ^= ")" then call error (SYNTAX, "");
412 lin = lin + 1;
413 end;
414
415 do rep_count = rep_count to 1 by -1;
416 if print_mode ^= 0 then
417 call print_text_$format (dp, name1);
418 k = dp -> ff.w0;
419 if base = -1 then do;
420 dp -> instr.offset = off;
421 dp -> instr.pr_bit = "0"b;
422 end;
423 else do;
424 dp -> instr_pr.pr = bit (fixed (base, 3));
425 dp -> instr_pr.offset = off;
426 dp -> instr.pr_bit = "1"b;
427 end;
428 dp -> instr.opcode = bit (fixed (op, 10));
429 dp -> instr.tag = bit (fixed (tag, 6));
430 dp -> instr.inhibit = "0"b;
431 i = dp -> ff.w0;
432 if print_mode ^= 0 then do;
433 call print_text_$format (dp, name2);
434 call ioa_$ioa_stream (debug_output, "^a^/^Nto^O^/^a", name1, name2);
435 end;
436 dp = addrel (dp, 1);
437 end;
438
439 return;
440
441 end get_instruction;
442
443
444
445 ^L
446
447
448
449
450
451 store_value: proc;
452
453 len_ptr = null;
454 if old_type = 0 then cur_size, old_size = size;
455 else if cur_size < old_size then len_ptr = addrel (dp, -1);
456 if type <= 4 then do;
457
458
459 if old_type = 0 then old_size = 36 - fixed (addr (dp) -> its.bit_offset, 6);
460 end;
461
462 if type = 21 then do;
463 if old_type ^= 21 & old_type ^= 0 then do;
464 old_size = divide (old_size, 9, 17, 0);
465 cur_size = divide (cur_size, 9, 17, 0);
466 end;
467 if old_size <= 0 then call error (TOO_BIG, "");
468 size = min (old_size, size);
469 new_size = rep_count*size;
470 if print_mode ^= 0 then do;
471 if rep_count > 1 then call ioa_$ioa_stream (debug_output, """^a"" to (^d)""^a""", substr (dp -> repstr, 1, new_size), rep_count, str);
472 else call ioa_$ioa_stream (debug_output, """^a"" to ""^a""", substr (dp -> old_str, 1, cur_size), str);
473 end;
474 do rep_count = rep_count to 1 by -1;
475 old_str = str;
476 dp = addr (dp -> chars (size));
477 end;
478 if len_ptr ^= null then do;
479 len_ptr -> fword = min (new_size, old_size);
480 cur_size = old_size;
481 end;
482 rep_count = 1;
483 end;
484
485 else if type = 19 then do;
486 if old_type = 21 then do;
487 old_size = 9*old_size;
488 cur_size = 9*cur_size;
489 end;
490 size = min (old_size, size);
491 new_size = rep_count*size;
492
493 do rep_count = rep_count to 1 by -1;
494 if print_mode ^= 0 then
495 call ioa_$ioa_stream (debug_output, """^a""b to ""^a""b", char (substr (dp -> old_bits, 1, cur_size)),
496 char (tp -> new_bits));
497 dp -> old_bits = new_bits;
498 dp = addr (dp -> bitarr (size));
499 end;
500 if len_ptr ^= null then do;
501 len_ptr -> fword = min (new_size, old_size);
502 cur_size = old_size;
503 end;
504 end;
505
506 else if type = 13 then do while (rep_count > 0);
507 if old_type = 0 then dp = addrel (dp, 0);
508 if old_size < 36 then call error (TOO_BIG, "");
509 if old_size < 72 then do;
510 unspec (old_ptr) = unspec (dp -> packed_ptr);
511 if size = 36 then
512 unspec (new_ptr), unspec (dp -> packed_ptr) = unspec (tp -> packed_ptr);
513 else unspec (new_ptr), unspec (dp -> packed_ptr) = unspec (tp -> bptr);
514 end;
515 else do;
516 unspec (old_ptr) = unspec (dp -> bptr);
517 if size = 36 then
518 unspec (new_ptr), unspec (dp -> bptr) = unspec (tp -> packed_ptr);
519 else unspec (new_ptr), unspec (dp -> bptr) = unspec (tp -> bptr);
520 end;
521
522 if print_mode ^= 0 then
523 call ioa_$ioa_stream (debug_output, "^p to ^p", old_ptr, new_ptr);
524 call bump;
525 end;
526
527 else if type = 14 then do while (rep_count > 0);
528 if old_size < 36 then call error (TOO_BIG, "");
529 if print_mode ^= 0 then do;
530 old_word = old_bits;
531 new_word = new_bits;
532 call ioa_$ioa_stream (debug_output, "^w to ^w", old_word, new_word);
533 end;
534
535 old_bits = new_bits;
536 call bump;
537 end;
538
539
540 else if type = 1 | type = 2 then do;
541 if ^dec_default then do;
542 if substr (il, index_start_no, 2) = "&d" then control = "^d to ^d";
543 else if old_size = 36 then control = "^w to ^w";
544 else control = "^o to ^o";
545 end;
546 else do;
547 if substr (il, index_start_no, 2) = "&o" then control = "^o to ^o";
548 else control = "^d to ^d";
549 end;
550 do while (rep_count > 0);
551 if abs (fix_bit$double ((new_bits), size)) >= binary (2)** (old_size) then call error (TOO_BIG, "");
552 if dp -> sign_bit then old_sign = -1;
553 else old_sign = 1;
554
555 if tp -> sign_bit then new_sign = -1;
556 else new_sign = 1;
557
558 if print_mode ^= 0 then do;
559 if old_size <= 36 then do;
560 old_word = old_bits;
561 new_word = new_bits;
562 call ioa_$ioa_stream (debug_output, control, fix_bit (old_word, old_size),
563 fix_bit (new_word, size));
564 end;
565
566 else do;
567 old_double = fix_bit$double ((old_bits), old_size);
568 new_double = fix_bit$double ((new_bits), size);
569 if dec_default then call ioa_$ioa_stream (debug_output, control,
570 addr (old_double) -> ffdouble, addr (new_double) -> ffdouble);
571 else call ioa_$ioa_stream (debug_output, "^w^w to ^w^w", addr (old_double) -> ff.w0,
572 addr (old_double) -> ff.w1,
573 addr (new_double) -> ff.w0, addr (new_double) -> ff.w1);
574 end;
575 end;
576
577 if size >= old_size then
578 old_bits = substr (new_bits, size-old_size+1);
579 else do;
580 pad_bits = old_size - size;
581 if new_sign < 0 then substr (old_bits, 1, pad_bits) = ones;
582 else substr (old_bits, 1, pad_bits) = "0"b;
583
584 substr (old_bits, pad_bits+1) = new_bits;
585 end;
586
587 call bump;
588 end;
589 end;
590
591 else if type = 3 | type = 4 then do;
592 do while (rep_count > 0);
593 if old_size < 9 then call error (TOO_BIG, "");
594
595 if print_mode ^= 0 then do;
596 on underflow begin;
597
598 call ioa_$ioa_stream (debug_output, "^w to ^w", dp -> fword, tp -> fword);
599 goto rev_under;
600 end;
601
602 call ioa_$ioa_stream (debug_output, "^12.4f to ^12.4f", addr (old_bits) -> flword,
603 addr (new_bits) -> flword);
604 rev_under: revert underflow;
605 end;
606
607 old_bits = substr (new_bits, 1, min (old_size, size));
608 call bump;
609 end;
610 end;
611
612
613 else call error (SYNTAX, "");
614 return;
615
616
617 end store_value;
618
619 ^L
620
621
622
623
624
625
626
627
628
629 get_rep_count: proc (rep);
630
631 dcl rep fixed bin;
632
633 rep = 1;
634 i = lin;
635 if get_char (lin + 1) then do;
636 k = lin;
637 j = db_get_count$dec (il, lin, lin);
638
639 if lin = k then do;
640 lin = i;
641 mode = "(";
642 return;
643 end;
644
645 if get_char (lin) then if mode = ")" then do;
646 if j < 1 then call error (BAD_REP, "");
647 if ^get_char (lin + 1) then call error (SYNTAX, "");
648 rep = j;
649 return;
650 end;
651 end;
652
653 call error (MISS_PAREN, "");
654
655 end get_rep_count;
656
657 end db_assign;