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 /* program to process length operator
 12 
 13           Written:  23 April 1974 by RAB
 14           Modified: 18 November 1974 by RAB for assign of desc elim   */
 15 
 16 length_op:          proc(pt) returns(ptr);
 17 
 18 dcl       pt ptr;             /* points at operator node */
 19 
 20 dcl       (p,p1,p2,q,s,s2) ptr;
 21 dcl       (doing_length,useless) bit(1) aligned;
 22 
 23 dcl       cg_stat$cur_block ptr ext static;
 24 
 25 dcl       adjust_ref_count entry(ptr,fixed bin);
 26 dcl       call_op entry(ptr) returns(ptr);
 27 dcl       compile_exp$save entry(ptr) returns(ptr);
 28 dcl       create_symbol entry(ptr,ptr,bit(3) aligned) returns(ptr);
 29 dcl       generate_constant$real_fix_bin_1 entry(fixed bin) returns(ptr);
 30 dcl       prepare_operand entry(ptr,fixed bin,bit(1) aligned) returns(ptr);
 31 dcl       share_expression entry(ptr) returns(ptr);
 32 
 33 dcl       null builtin;
 34 
 35 dcl       fix_bin(0:1) fixed bin based;
 36 
 37 %include cgsystem;
 38 %include symbol;
 39 %include reference;
 40 %include operator;
 41 %include boundary;
 42 %include data_types;
 43 %include nodes;
 44 %include temporary;
 45 %include op_codes;
 46 
 47           doing_length = "1"b;
 48 
 49 begin:
 50           p = pt;
 51           q = p -> operand(1);
 52 
 53           /* get reference to length field (-1) of varying string */
 54 
 55           p2 = p -> operand(2);
 56 
 57           if p2 -> node.type = operator_node
 58           then if p2 -> operand(1) -> reference.evaluated
 59                then p2 = p2 -> operand(1);
 60                else if p2 -> operator.op_code = std_call
 61                     then p2 = call_op(p2);
 62                     else p2 = compile_exp$save(p2);
 63 
 64           s2 = p2 -> reference.symbol;
 65           if s2 -> symbol.constant & p2 -> reference.offset = null
 66                then return(generate_constant$real_fix_bin_1(s2 -> symbol.initial -> fix_bin
 67                               (p2 -> reference.c_offset)));
 68 
 69           p2 = prepare_operand(p2,1,useless);
 70 
 71           /* we need a new symbol to hold both the proper storage
 72              class and the proper precision */
 73 
 74           s = create_symbol(null,null,(s2 -> symbol.dcl_type));
 75           p1 = s -> symbol.reference;
 76           s -> symbol.attributes = s2 -> symbol.attributes;
 77           s -> symbol.location = s2 -> symbol.location;
 78           s -> symbol.block_node = s2 -> symbol.block_node;
 79           s -> symbol.father = s2 -> symbol.father;
 80           s -> symbol.initial = s2 -> symbol.initial;
 81           s -> symbol.allocated = s2 -> symbol.allocated;
 82           s -> symbol.token = s2 -> symbol.token;
 83           string (s -> symbol.data_type) = string (q -> reference.symbol -> symbol.data_type);
 84           s -> symbol.binary = "1"b;
 85           s -> symbol.c_bit_size = bits_per_word;
 86           s -> symbol.c_word_size = 1;
 87           s -> symbol.c_dcl_size = q -> reference.symbol -> symbol.c_dcl_size;
 88 
 89           /* set up the reference node */
 90 
 91           p1 -> reference = p2 -> reference;
 92           p1 -> reference.shared = "0"b;
 93           if q -> reference.shared
 94                then p1 -> reference.ref_count = 1;
 95                else p1 -> reference.ref_count = q -> reference.ref_count;
 96 
 97           q = p1;
 98           q -> reference.symbol = s;
 99           p -> operand(1) = q;
100 
101           string(q -> reference.info) = "0"b;
102           q -> reference.value_in.storage = p2 -> reference.value_in.storage;
103 
104           if doing_length
105                then q -> reference.c_offset = q -> reference.c_offset - 1;
106           q -> reference.units = word_;
107           q -> reference.data_type = real_fix_bin_1;
108           q -> reference.varying_ref = "0"b;
109           q -> reference.c_length = bits_per_word;
110           string(q -> reference.bits) = "0100000111000"b;   /* aligned, evaluated, allocate, allocated */
111 
112           q -> reference.defined_ref = s -> symbol.defined;
113           q -> reference.aliasable = s -> symbol.aliasable | (s -> symbol.auto
114                                         & (cg_stat$cur_block ^= s -> symbol.block_node)
115                                         & s -> symbol.passed_as_arg);
116           q -> reference.temp_ref = s -> symbol.temporary;
117           q -> reference.aggregate = p2 -> reference.aggregate;
118           q -> reference.perm_address = "0"b;
119           q -> reference.no_address = "1"b;
120 
121           if q -> reference.qualifier ^= null
122           then if q -> reference.qualifier -> node.type = temporary_node
123                then q -> reference.qualifier -> temporary.ref_count = q -> reference.qualifier -> temporary.ref_count + 1;
124                else q -> reference.qualifier = share_expression((q -> reference.qualifier));
125 
126           if q -> reference.offset ^= null
127                then q -> reference.offset = share_expression((q -> reference.offset));
128 
129           if ^ p2 -> reference.shared
130                then call adjust_ref_count(p2,-1);
131 
132           return(q);
133 
134 
135 assign_desc_op:     entry(pt) returns(ptr);
136 
137           /* eliminate assignment of descriptor to temporary */
138 
139           doing_length = "0"b;
140           go to begin;
141           end;