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 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;                                   /* ill -1 (line ends with new_line) */
 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;                              /* index in il of the beginning of a type 1 no. string */
 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",                                /* TOO_BIG */
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;                              /* 1 = decimal default
129                                                                0 = octal default ( registers, temporaries ) */
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;                              /* variable ioa_ control string */
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 /*        The following declaration is included(temporarily) to allow
153    *      the use of the old-style names of the pointer registers.
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;                         /* used for printing double words in ^d */
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                                                             /* ^L */
170 %include db_snt;
171 /* ^L */
172 %include db_inst;
173 /* ^L */
174 %include its;
175 /* ^L */
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,                             /* 0 - desc9a, 1 - descb, 2 - decimal */
181 
182     2 num_desc fixed bin (5) unal,
183     2 num_words fixed bin (8) unal;
184 
185 %include db_data_map;
186 /* ^L */
187 
188           temp = addr (tem);                                /* get pointer to temporary storage */
189           dp = data_ptr;                                    /* get pointer to first word to change */
190           cur_size = a_cur_size;
191           old_size = a_old_size;
192 
193 
194 /*  If the user does not have w access on the segment, try to add w user.proj.tag  */
195 
196           call hcs_$fs_get_mode (dp, emode, code35);        /* see if the user has write permit on the segment */
197           if code35 = 0 then do;
198                if bit (emode, 5) & "00010"b then access_ok = 1; /* if write permit is there, OK */
199                else do;
200                     access_ok = 0;                          /* hasn't got write permit, change the access */
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;                           /* Can't get write access on segment */
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); /* print out location changings */
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;     /* instruction format  (opcode) */
220                else if mode = "$" then do;                  /* register being used as value */
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); /* copy register name into temporary */
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;                                     /* call db_parse_arg to pick off the other types */
247                     index_start_no = lin;                   /* patch for octal default */
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); /* scan for next item */
259                     tp = temp;
260 
261                     if type = -1 then goto reset;           /* goto reset if ";", etc. */
262 
263                     if type = 1 | type = 3 then size = 36;  /* arithmetic type s go in fullword */
264                     if type = 13 then size = 72;            /* pointer on double-word */
265 
266                     if type = 0 then do;                    /* a variable as input parameter */
267                          db_sym_name = str;                 /* copy variable name into temporary */
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 /* ^L */
283 bump:     proc;
284 
285 /*        This internal procedure is used to bump the data pointer
286    *      to the next item after the one just assigned to.
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;                 /* into next word */
294                     new_bit_off = new_bit_off - 36;
295                     off_inc = off_inc + 1;                  /* must bump word offset */
296                end;
297 
298                dp = addrel (dp, off_inc);                   /* this will set bit offset */
299                                                             /* to zero, so we may have  */
300                if new_bit_off ^= 0 then                     /* to set it again */
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 /*  This procedure is an error exit from db_assign.  It prints an error message and goes to reset. */
312 
313 error:    proc (mess_code, illegal_string);
314 
315 dcl  mess_code fixed bin;                                   /* error codes for db_assign */
316 dcl  illegal_string char (*) aligned;                       /* offending character or string */
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 /*  This procedure looks for a non_blank character and sets mode to it.  If mode is ";" or there
326     are no more characters left in the line, then get_char returns "0"b.  Otherwise
327    it returns "1"b (for found next character).
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 /*  This procedure attempts to parse an instruction of the form:
353 
354           ( opcode base|offset,tag )
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), " )"); /* blank or ) follows opcode */
362                if j = 0 then call error (MISS_PAREN,  "");
363                opcode6 = substr (il, lin, j -1);            /* copy opcode name */
364                lin = lin + j -1;
365                op = -1;
366                do i = 0 to 1023 while (op = -1);            /* search for the opcode */
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;                                   /* -1 indicates no pr specified */
373 
374                if substr (il, lin+3, 1) = "|" then do;      /* standard pointer register prN|NN */
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; /*  old-style pointer pp|NN */
383                     c2 = substr (il, lin, 2);               /* copy it for compare */
384                     lin = lin + 3;                          /* increment index */
385                     base = -1;
386                     do i = 0 to 7 while (base = -1);        /* search for the base name */
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;                                     /* check for number */
393                off = db_get_count (il, lin, lin);           /* pick up the offset specified by the user */
394                if j = lin then if substr (il, lin, 1) = ")" then off = 0; /* not a number */
395                     else call error (SYNTAX, "");
396                tag = 0;                                     /* indicates tag not yet specified */
397                if substr (il, lin, 1) = "," then do;        /* a tag was specified */
398                     j = index (substr (il, lin+1, 4), ")"); /* find location of the ")" */
399                     if j = 0 then call error (MISS_PAREN,  "");       /* error condition */
400                     c4 = substr (il, lin, j);               /* pick up the tag field */
401                     lin = lin+j+1;                          /* skip over rest of instruction input */
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;                        /* save the old value */
419                     if base = -1 then do;                   /* a base was never spec ified */
420                          dp -> instr.offset = off;          /* copy full offset into instruction */
421                          dp -> instr.pr_bit = "0"b;         /* make sure don't use base */
422                     end;
423                     else do;
424                          dp -> instr_pr.pr = bit (fixed (base, 3)); /* copy base into instruction */
425                          dp -> instr_pr.offset = off;       /* copy offset */
426                          dp -> instr.pr_bit = "1"b;         /* turn on bit 29 */
427                     end;
428                     dp -> instr.opcode = bit (fixed (op, 10)); /* fill in opcode */
429                     dp -> instr.tag = bit (fixed (tag, 6)); /* fill in tag */
430                     dp -> instr.inhibit = "0"b;
431                     i = dp -> ff.w0;                        /* get new value */
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 /*  This procedure has a value and stores it at the location given with dp.  Rep_count  is the number of
448     times to repeat a given value.
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                                                             /* for arithmetic values, if not a variable specified on left, just fill in rest of word */
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;                        /* character string */
463                     if old_type ^= 21 & old_type ^= 0 then do;
464                          old_size = divide (old_size, 9, 17, 0); /* convert size from bits to chars */
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;             /* if a varying string, update length */
479                          len_ptr -> fword = min (new_size, old_size);
480                          cur_size = old_size;               /* so we won't do it again */
481                     end;
482                     rep_count = 1;
483                end;
484 
485                else if type = 19 then do;                   /* bit string */
486                     if old_type = 21 then do;               /* if char string, convert size to bits */
487                          old_size = 9*old_size;
488                          cur_size = 9*cur_size;
489                     end;
490                     size = min (old_size, size);            /* bit string */
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); /* pointer */
507                     if old_type = 0 then dp = addrel (dp, 0); /* eliminate bit offset if not var. */
508                     if old_size < 36 then call error (TOO_BIG, "");
509                     if old_size < 72 then do;               /* into packed ptr */
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); /* offset variable */
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;         /* fixed bin */
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;                                /* decimal default assumed unles &o was used */
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;           /* maybe some value wasn't really */
597                                                             /* floating, so print it out octal */
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 /*  This procedure attempts to get a repetition count.  It assumes a format:
622 
623           [blank(s)]  [decimal digit(s)]  [blank(s)]
624 
625     If the string is not a repetion count, lin and mode are restored.  The main procedure  will then
626     try to parse an instruction
627 */
628 
629 get_rep_count: proc (rep);
630 
631 dcl  rep fixed bin;
632 
633                rep = 1;
634                i = lin;                                     /* save in  case this is not repetition */
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;