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 /* Modified Dec 1978 by David Spector for new xref 'set' format */
 12 /* Modified 79/04/19 by Peter Krupp to implement 4-bit decimal */
 13 
 14 expand_initial: proc(sp,st,locator);
 15 
 16 dcl       (s,sp,st,blk,p,q,lab,swt,increase,subscript,total_size,nest,allocate,one,ar,r,a,b,v,off) ptr;
 17 dcl       (d,locator,stat) ptr;
 18 dcl       (c_total_size,coff) fixed bin(31);
 19 dcl       (n,i,total_elements) fixed bin(15);
 20 
 21 dcl       units fixed bin(3);
 22 dcl       round(4) fixed bin(15) int static initial(36,0,4,2);
 23 dcl       optable(4) bit(9) aligned initial(bit_to_word,""b,char_to_word,half_to_word);
 24 
 25 dcl       (constant_extents,temporary_required) bit(1) aligned;
 26 
 27 dcl       fab_image aligned bit(length(unspec(fab))) based(addr(fab));
 28 dcl       1 fab,
 29           2 bits,
 30           3 fill1 bit(27),
 31           3 internal bit(1),
 32           3 fill2 bit(8),
 33           2 title char(32),
 34           2 line_size fixed bin(15),
 35           2 page_size fixed bin(15),
 36           2 buffer_size fixed bin(15);
 37 
 38 dcl       (null,string,fixed,length,unspec,addr,binary,bit) builtin;
 39 ^L
 40           s = sp;
 41           stat = st;
 42           one = declare_constant$integer(1);
 43           blk = s->symbol.block_node;
 44           s->symbol.allocate  ,
 45           s->symbol.set = "1"b;
 46 
 47           if s->symbol.constant
 48           then do;
 49                     q = create_operator(jump_if_eq,3);
 50                     q->operand(1),lab = create_label(blk,null,by_compiler);
 51                     q->operand(2),swt = declare_integer(blk);
 52                     q->operand(3) = one;
 53 
 54                     swt->reference.symbol->symbol.static,
 55                     swt->reference.symbol->symbol.internal,
 56                     swt->reference.symbol->symbol.allocate = "1"b;
 57                     swt->reference.symbol->symbol.auto = "0"b;
 58                     /* int static is assumed to be initialized to zero */
 59 
 60                     p = make_statement(if_statement,q);
 61 
 62                     /* create an internal static file state block of 290 words and set the "general"
 63                     pointer of the file constant's symbol node to point to the symbol node of the
 64                     file state block.  */
 65 
 66                     p = create_symbol(blk,create_token(s->symbol.token->token.string||".fsb"
 67                               ,identifier),by_compiler);
 68                     p->symbol.c_dcl_size = 290;
 69                     p->symbol.storage_block,p->symbol.static = "1"b;
 70                     p->symbol.external = s->symbol.external;
 71                     p->symbol.internal = s->symbol.internal;
 72                     p->symbol.allocate = "1"b;
 73                     call get_size(p);
 74                     p->symbol.boundary = mod2_;
 75                     s->symbol.general = p;
 76 
 77                     /* create a file attribute block that contains the initial attribute set used when
 78                     opening the file control block.    */
 79 
 80                     string(fab.bits) = "0010"b||string(s->symbol.file_attributes);
 81                                         /* "001"b marks the file as version 2 */
 82                     fab.internal = s->symbol.internal;
 83                     fab.title = s->symbol.token->token.string;
 84                     fab.line_size,fab.page_size,fab.buffer_size = 0;
 85                     q = declare_constant$bit(fab_image);
 86                     p->symbol.general = q->reference.symbol;
 87 
 88 
 89                     /* generate prologue to assign the addr(fab) to the 1st pointer
 90                     of the file constant, and the addr(fsb) to the 2nd pointer.  */
 91 
 92                     a = create_operator(addr_fun,2);
 93                     a->operand(2) = q;
 94                     q = make_statement(assignment_statement,assignf((s->symbol.reference),a));
 95                     a = create_operator(addr_fun,2);
 96                     a->operand(2) = p->symbol.reference;
 97                     q = copy_expression(s->symbol.reference);
 98                     q->reference.shared = "0"b;
 99                     q->reference.ref_count = 1;
100                     q->reference.c_offset = 2;
101                     q->reference.units = word_;
102                     q = make_statement(assignment_statement,assignf(q,a));
103 
104                     p = make_statement(assignment_statement,assignf(swt,one));
105                     p = make_statement(null_statement,null);
106                     p->statement.labels = create_list(2);
107                     p->statement.labels->element(2) = lab;
108                     lab->label.statement = p;
109                     return;
110           end;
111 
112           if s->symbol.area
113           then do;
114                     if s->symbol.based | s->symbol.controlled
115                     then do;
116                               p  ,
117                               stat = create_statement(assignment_statement,stat,null,(stat->statement.prefix));
118                               p->statement.generated = "1"b;
119                     end;
120                     else      p = create_statement$prologue(assignment_statement,blk,null,(blk->block.prefix));
121 
122                     p->statement.root  ,
123                     q = create_operator(assign,2);
124 
125                     r = create_reference((s->symbol.token));
126 
127                     if locator^=null
128                     then      r->reference.qualifier = copy_expression((locator));
129 
130                     if s->symbol.father^=null
131                     then      call link_father();
132 
133                     q->operand(1) = r;
134                     q->operand(2) = create_reference(create_token("empty",identifier));
135 
136                     q->operand(2)->reference.offset = create_list(0);
137 
138                     return;
139           end;
140 
141           if s->symbol.initialed
142           then do;
143                     q = s->symbol.initial;
144                     if s->symbol.dimensioned
145                     then      goto array_initialization;
146                     else do;
147                               r = create_reference((s->symbol.token));
148                               r->reference.qualifier = copy_expression((locator));
149 
150                               if s->symbol.father^=null
151                               then      call link_father();
152 
153 unravel:                      if q->element(3)^=null
154                               then      call semantic_translator$abort(442,s);
155 
156                               if q->element(1)->node.type^=token_node
157                               then      call semantic_translator$abort(442,s);
158 
159                               if q->element(1)->token.type^=dec_integer
160                               then      call semantic_translator$abort(442,s);
161 
162                               if token_to_binary((q->element(1)))^=1
163                               then      call semantic_translator$abort(442,s);
164 
165                               if q->element(2) ^= null
166                               then      if q->element(2)->node.type = list_node
167                               then do;
168                                         q = q->element(2);
169                                         go to unravel;
170                               end;
171 
172                               p = make_statement(assignment_statement,assignf(r,(q->element(2))));
173                     end;
174           end;
175 
176           return;
177 ^L
178 /* prepare for array initialization by getting a subscript, code to increment the subscript,
179    and a reference to an array element. */
180 
181 array_initialization:
182           subscript = declare_integer(blk);
183           increase = assignf(subscript,addf(subscript,one));
184           r = create_reference(s);
185           r->reference = s->symbol.reference->reference;
186           r->reference.array_ref = "0"b;
187           r->reference.qualifier = copy_expression((locator));
188           r->reference.symbol = s->symbol.token;
189 
190           if s->symbol.father^=null
191           then      call link_father();
192 
193           a = s->symbol.array;
194           n = a->array.number_of_dimensions;
195           r->reference.offset = create_list(n);
196 
197           total_elements = 0;
198           constant_extents = "1"b;
199 
200 /* insure that the high and low bounds are available in the object program.     */
201 
202           do b = a->array.bounds repeat b->bound.next while(b ^= null);
203                     if b->bound.lower=null
204                     then      b->bound.lower = declare_constant$integer((b->bound.c_lower));
205                     else      constant_extents = "0"b;
206 
207                     if b->bound.upper=null
208                     then      b->bound.upper = declare_constant$integer((b->bound.c_upper));
209                     else      constant_extents = "0"b;
210 
211                     if constant_extents
212                     then      if total_elements=0
213                               then      total_elements = b->bound.c_upper-b->bound.c_lower+1;
214                               else      total_elements = total_elements * (b->bound.c_upper-b->bound.c_lower+1);
215           end;
216 
217 /* if this is a vector call assign_initial to create assignments from the initial attribute
218    to elements of the vector.  The number of elements  in the vector is assumed to be
219    equal to or greater than the number of elements in the initial attribute. */
220 
221           if n = 1
222           then do;
223                     if a->array.bounds->bound.c_lower = 1
224                     then      p = declare_constant$integer(0);
225                     else      p = subf((a->array.bounds->bound.lower),one);
226 
227                     p = make_statement(assignment_statement,assignf(subscript,p));
228                     r->reference.offset->element(1) = subscript;
229                     p = make_statement(assignment_statement,assign_initial(q,null,0,"1"b,temporary_required));
230 
231                     return;
232           end;
233 
234 /* Create a vector whose elements have the same attributes as the elements of
235    the array.  The initial attribute values are assigned to the vector using
236    the procedure assign_initial.  The vector is made large enough to
237    hold all the values given in the initial attribute.      */
238 
239           p=make_statement(assignment_statement,assignf(subscript,declare_constant$integer(0)));
240           allocate = make_statement(null_statement,null);
241           p = create_symbol(blk,null,by_compiler);
242           p->symbol.auto = "1"b;
243           string(p->symbol.data_type) = string(s->symbol.data_type);
244           string(p->symbol.misc_attributes) = string(s->symbol.misc_attributes);
245           p->symbol.member = "0"b;
246           p->symbol.c_dcl_size = s->symbol.c_dcl_size;
247           p->symbol.scale = s->symbol.scale;
248           p->symbol.dcl_size = s->symbol.dcl_size;
249 
250           unspec (p->symbol.pix) = unspec (s->symbol.pix);
251           if s -> symbol.picture then p -> symbol.general = s -> symbol.general;
252 
253           if p->symbol.varying
254           then      p->symbol.reference->reference.varying_ref = "1"b;
255           else do;
256                     p->symbol.reference->reference.c_length = s->symbol.reference->reference.c_length;
257                     p->symbol.reference->reference.length = s->symbol.reference->reference.length;
258           end;
259 
260           p->symbol.boundary = s->symbol.boundary;
261 
262           v  ,
263           p->symbol.array = create_array();
264           v->array.number_of_dimensions = 1;
265           v->array.own_number_of_dimensions = 1;
266           v->array.virtual_origin  ,
267           v->array.element_size = a->array.element_size;
268           v->array.c_virtual_origin  ,
269           v->array.c_element_size = a->array.c_element_size;
270           v->array.c_element_size_bits = a->array.c_element_size_bits;
271           v->array.offset_units = a->array.offset_units;
272 
273           b  ,
274           v->array.bounds = create_bound();
275           b->bound.c_lower = 1;
276           b->bound.c_multiplier = v->array.c_element_size;
277           b->bound.multiplier = v->array.element_size;
278           if b->bound.multiplier = null
279           then      b->bound.multiplier = declare_constant$integer((b->bound.c_multiplier));
280 
281           total_size = null;
282           c_total_size = 0;
283           ar = r;
284 
285           r = create_reference((p->symbol.token));
286           r->reference.offset = create_list(1);
287           r->reference.offset->element(1) = subscript;
288           q = make_statement(assignment_statement,assign_initial(q,total_size,c_total_size,"1"b,temporary_required));
289 
290           if temporary_required
291           then      if total_size=null
292                     then do;
293                               total_size = declare_constant$integer(c_total_size);
294                               c_total_size = 0;
295                     end;
296 
297 
298 /* set the upper bound of the vector to the number of items in the initial attribute.  */
299 
300           b->bound.upper = total_size;
301           b->bound.c_upper = c_total_size;
302 
303 /* set the size of the vector to the number of values found in the initial attribute
304    times the size of an element of the vector.    */
305 
306           if total_size = null
307           then      if a->array.element_size = null
308                     then      c_total_size = c_total_size*a->array.c_element_size;
309                     else      total_size = multf((a->array.element_size),declare_constant$integer(c_total_size));
310           else      if a->array.element_size = null
311                     then      if a->array.c_element_size ^= 1
312                               then      total_size = multf(total_size,declare_constant$integer((a->array.c_element_size)));
313                               else;
314                     else      total_size = multf(total_size,(a->array.element_size));
315 
316 /* Change total_size and c_total_size to be in units of words */
317 
318           units = v->array.offset_units;
319           if units < word_
320           then do;
321                     if total_size ^= null
322                     then do;
323                               q = create_operator(optable(units),2);
324                               q->operand(2) = total_size;
325                               total_size = q;
326                     end;
327                     else      c_total_size = divide(c_total_size+round(units)-1,round(units),31,0);
328           end;
329 
330           p->symbol.word_size = total_size;
331           p->symbol.c_word_size = c_total_size;
332 
333           if total_size ^= null
334           then do;
335                     p->symbol.exp_extents = "1"b;
336                     q = create_operator(allot_auto,2);
337                     p->symbol.reference->reference.qualifier  ,
338                     q->operand(1) = declare_pointer(blk);
339                     q->operand(2) = total_size;
340                     allocate->statement.root = copy_expression((q));
341                     allocate->statement.statement_type = assignment_statement;
342           end;
343 
344 /* create code to copy the elements of the vector into the array.  The bounds of the
345    array are used to control the loop.  The number of elements in the vector is
346    assumed to equal or exceed the number of elements in the array.    */
347 
348           q = make_statement(assignment_statement,assignf(subscript,declare_constant$integer(0)));
349           nest = create_operator(join,2);
350           nest->operand(1) = increase;
351           nest->operand(2) = assignf(ar,r);
352 
353           i = 0;
354 
355           do b = a->array.bounds repeat b->bound.next while(b^=null);
356                     i = i+1;
357                     q = create_operator(loop,5);
358                     q->operand(1) = nest;
359                     q->operand(2)  ,
360                     ar->reference.offset->element(i) = declare_integer(blk);
361                     q->operand(3) = b->bound.lower;
362                     q->operand(4) = b->bound.upper;
363                     nest = q;
364           end;
365 
366           q = make_statement(assignment_statement,nest);
367 
368           return;
369 ^L
370 /* subroutine to assign the values of an initial attribute to a vector.         */
371 
372 assign_initial: proc(init,count,c_count,check_range,temporary_reqd) returns(ptr);
373 
374 dcl       (init,count,numb,p,v,t,q,q1) ptr;
375 dcl       stack(1024) ptr unal;
376 dcl       (i,k,l,items,limit) fixed bin(15),
377           n fixed bin(15) init(0);
378 dcl       (c_count,c_numb,case) fixed bin(31);
379 
380 dcl       (check_range,temporary_reqd) bit(1) aligned;
381 dcl       hbound builtin;
382 
383           limit = divide(hbound(stack,1),2,15,0);
384           items, l = 0;
385           temporary_reqd = "0"b;
386 
387           do p = init repeat p->element(3) while(p^=null);
388                     t = p->element(1);            /* repetition factor */
389                     v = p->element(2);            /* value */
390 
391                     n = 0;
392                     case = 1;
393 
394                     if t->node.type = token_node
395                     then      if t->token.type = dec_integer
396                               then do;
397                                         n = token_to_binary(t);
398                                         if n < 6 then case = 0;
399                               end;
400                               else      check_range = "0"b;
401                     else      check_range = "0"b;
402 
403                     if v=null
404                     then      ;
405                     else      if v->node.type=list_node
406                               then      case = 2;
407 
408                     go to action(case);
409 
410 action(0):
411                     /* optimized special case */
412 
413                     if count=null
414                     then      c_count = c_count+n;
415                     else      count = addf(count,declare_constant$integer((n)));
416 
417                     do k = 1 to n;
418                               items = items + 1;
419                               l = l+2;
420                               if items > limit
421                               then      call semantic_translator$abort(264,s);
422 
423                               stack(l-1) = increase;
424                               stack(l) = assignf(r,v);
425                     end;
426 
427                     go to next;
428 
429 action(1):
430                     /* normal case */
431 
432                     temporary_reqd = "1"b;
433 
434                     q = assignf(r,v);
435 
436                     if count=null
437                     &  n^=0
438                     then      c_count = c_count+n;
439                     else      if count=null
440                               then      count = t;
441                               else      count = addf(count,t);
442 
443                     q1 = create_operator(join,2);
444                     q1->operand(1) = increase;
445                     q1->operand(2) = q;
446                     q = create_operator(loop,5);
447                     q->operand(1) = q1;
448                     q->operand(2) = declare_integer(blk);
449                     q->operand(3) = one;
450                     q->operand(4) = t;
451 
452                     items = items + 1;
453                     l = l+1;
454                     if items > limit
455                     then      call semantic_translator$abort(264,s);
456                     stack(l) = q;
457 
458                     goto next;
459 
460 action(2):
461                     /* difficult case -- initial value is a list */
462 
463                     temporary_reqd = "1"b;
464 
465                     numb = null;
466                     c_numb = 0;
467                     q = assign_initial(v,numb,c_numb,"0"b,"0"b);
468 
469                     if t->node.type=token_node
470                     then      if t->token.type=dec_integer
471                               then      n = token_to_binary(t);
472                               else      check_range = "0"b;
473                     else      check_range = "0"b;
474 
475                     if n^=0
476                     &  numb=null
477                     then      c_numb = c_numb*n;
478                     else      if numb=null
479                               then      numb=multf(declare_constant$integer(c_numb),t);
480                               else      numb = multf(numb,t);
481 
482                     if count=null
483                     &  numb=null
484                     then      c_count = c_count+c_numb;
485                     else      if count=null
486                               then      if c_count=0
487                                         then      count = numb;
488                                         else do;
489                                                   count = addf(declare_constant$integer(c_count),numb);
490                                                   c_count = 0;
491                                         end;
492                               else      if c_numb=0
493                                         then      count = addf(count,numb);
494                                         else      count = addf(count,declare_constant$integer(c_numb));
495 
496                     q1 = create_operator(loop,5);
497                     q1->operand(1) = q;
498                     q1->operand(2) = declare_integer(blk);
499                     q1->operand(3) = one;
500                     q1->operand(4) = t;
501 
502                     items = items + 1;
503                     l = l+1;
504                     if items > limit
505                     then      call semantic_translator$abort(264,s);
506                     stack(l) = q1;
507 
508 next:
509           end;
510 
511 /* create a join of everything generated by this invocation of assign_initial. */
512 
513           q = create_operator(join,l);
514 
515           do i = 1 to l;
516                     q->operand(i) = stack(i);
517           end;
518 
519           if check_range
520           then      if constant_extents
521                     then      if count=null
522                               &  c_count^=total_elements
523                               then      call semantic_translator$abort(292,s);
524 
525           return(q);
526 
527           end assign_initial;
528 ^L
529 /* subroutine to make an assignment or arithmetic operators. */
530 
531 assignf: proc(v,e) returns(ptr);
532 
533 dcl       (v,e,q) ptr;
534 dcl       opcode bit(9) aligned;
535 
536           if e=null
537           then      q = create_operator(nop,0);
538           else do;
539                     q = create_operator(assign,2);
540                     q->operand(1) = v;
541                     q->operand(2) = e;
542           end;
543 
544           go to exit;
545 
546 addf: entry(v,e) returns(ptr);
547 
548           opcode = add;
549           go to common;
550 
551 subf: entry(v,e) returns(ptr);
552 
553           opcode = sub;
554           go to common;
555 
556 multf: entry(v,e) returns(ptr);
557 
558           opcode = mult;
559 
560 common:
561           q = create_operator(opcode,3);
562           q->operand(2) = v;
563           q->operand(3) = e;
564 
565 exit:
566           return(q);
567 
568           end;
569 ^L
570 /* subroutine to make a statement in the prologue or main code sequence. */
571 
572 make_statement: proc(type,e) returns(ptr);
573 
574 dcl       (e,p) ptr;
575 dcl       type bit(9) aligned;
576 
577           if s->symbol.based | s->symbol.controlled
578           then do;
579                     p  ,
580                     stat = create_statement(type,stat,null,(stat->statement.prefix));
581                     p->statement.root = copy_expression((e));
582                     p->statement.generated = "1"b;
583           end;
584           else do;
585                     p = create_statement$prologue(type,blk,null,(blk->block.prefix));
586                     p->statement.root = copy_expression((e));
587           end;
588 
589           return(p);
590 
591           end;
592 ^L
593 link_father:        proc();
594 
595 dcl       (i,count) fixed bin(15);
596 
597 dcl       (p,q) ptr;
598 
599           count = 0;
600 
601           do p = s->symbol.father repeat p->symbol.father while(p^=null);
602                     count = count+1;
603           end;
604 
605           r->reference.length  ,
606           q = create_list(count);
607           p = s->symbol.father;
608 
609           do i=1 to count;
610                     q->element(i) = p->symbol.token;
611                     p = p->symbol.father;
612           end;
613 
614           end link_father;
615 ^L
616 %include semant;
617 %include symbol;
618 %include boundary;
619 %include system;
620 %include label;
621 %include reference;
622 %include token;
623 %include token_types;
624 %include declare_type;
625 %include statement;
626 %include block;
627 %include statement_types;
628 %include op_codes;
629 %include operator;
630 %include array;
631 %include list;
632 %include nodes;
633 
634           end expand_initial;