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 /* procedure to generate a symbol node for a code generator constant
 12 
 13    Initial Version: 13 September 1971 by BLW
 14           Modified: 27 April 1972 by BLW
 15           Modified: 27 July 1973 by RAB */
 16 
 17 generate_constant: proc(const,n_words) returns(ptr) ;
 18 
 19 dcl       const bit(*) aligned,         /* constant to generate */
 20           n_words fixed bin;            /* number of words to gen, or zero */
 21 
 22 dcl       cg_stat$constant_list ptr ext;
 23 
 24 dcl       (p,q,pc) ptr,
 25           (n,n_bits,n_chars,dt) fixed bin,
 26           (dummy,bs,cs,reloc) bit(1) aligned,
 27           const_string bit(n_bits) aligned based;
 28 
 29 dcl       create_symbol entry(ptr,ptr,bit(3) aligned) returns(ptr);
 30 
 31 dcl       (addr,divide,length,null,string) builtin;
 32 
 33 %include pl1_tree_areas;
 34 %include cgsystem;
 35 %include reference;
 36 %include symbol;
 37 %include declare_type;
 38 %include data_types;
 39 %include boundary;
 40 
 41           pc = addr(const);
 42           dt = bit_string;
 43           bs = "1"b;
 44           cs, reloc = "0"b;
 45 
 46           if n_words ^= 0 then n = n_words;
 47           else n = divide(length(const) + bits_per_word - 1,bits_per_word,17,0);
 48 
 49 join:     n_bits = n * bits_per_word;
 50 
 51 join1:    p = cg_stat$constant_list;
 52           do while(p ^= null);
 53                if p -> symbol.varying then goto loop;
 54 
 55                if bs
 56                then do;
 57                     if ^ p -> symbol.bit then goto loop;
 58                     if p -> symbol.c_dcl_size ^= n_bits then goto loop;
 59                     end;
 60 
 61                if cs
 62                then do;
 63                     if ^ p -> symbol.char then go to loop;
 64                     if p -> symbol.c_dcl_size ^= n_chars then go to loop;
 65                     end;
 66 
 67                if reloc
 68                then if ^ p -> symbol.storage_block
 69                     then go to loop;
 70 
 71                if p -> symbol.c_word_size >= n
 72                then if p -> symbol.initial -> const_string = pc -> const_string
 73                     then goto done;
 74 
 75 loop:          p = p -> symbol.multi_use;
 76                end;
 77 
 78           allocate const_string in(tree_area) set(q);
 79           q -> const_string = pc -> const_string;
 80 
 81           p = create_symbol(null,null,by_compiler);
 82           p -> symbol.multi_use = cg_stat$constant_list;
 83           cg_stat$constant_list = p;
 84 
 85           p -> symbol.c_word_size = n;
 86 
 87           if ^ reloc
 88           then if n = 2
 89                then p -> symbol.boundary = mod2_;
 90                else p -> symbol.boundary = word_;
 91           else if double
 92                then p -> symbol.boundary = mod2_;
 93                else p -> symbol.boundary = word_;
 94 
 95           p -> symbol.c_bit_size = n_bits;
 96 
 97           if cs
 98           then do;
 99                p -> symbol.char = "1"b;
100                p -> symbol.c_dcl_size = n_chars;
101                end;
102           else do;
103                p -> symbol.c_dcl_size = n_bits;
104                if bs then p -> symbol.bit = "1"b;
105                if reloc then p -> symbol.storage_block = "1"b;
106                end;
107 
108           p -> symbol.initial = q;
109           p -> symbol.constant = "1"b;
110 
111           q = p -> symbol.reference;
112           q -> reference.c_length = p -> symbol.c_dcl_size;
113           if n_bits > bits_per_two_words then q -> reference.long_ref = "1"b;
114 
115 done:     q = p -> symbol.reference;
116           string(q -> reference.bits) = "11"b;
117           q -> reference.data_type = dt;
118           q -> reference.units = word_;
119           q -> reference.no_address = "1"b;
120           q -> reference.perm_address = "0"b;
121           return(q);
122 
123 generate_constant$real_fix_bin_1: entry(integer) returns(ptr);
124 
125 dcl       integer fixed bin;
126 
127           pc = addr(integer);
128           n = 1;
129           dt = real_fix_bin_1;
130           bs, cs, reloc = "0"b;
131           goto join;
132 
133 generate_constant$bit_string: entry(const,nb) returns(ptr);
134 
135 dcl       nb fixed bin;                 /* number of bits */
136 
137           n_bits = nb;
138           n = divide(n_bits + bits_per_word - 1,bits_per_word,17,0);
139           bs = "1"b;
140           cs, reloc = "0"b;
141 
142           pc = addr(const);
143           dt = bit_string;
144           goto join1;
145 
146 generate_constant$char_string:          entry(char_const,nc) returns(ptr);
147 
148 dcl       char_const char(*) aligned,
149           nc fixed bin;                 /* number of characters in char_const */
150 
151           n_chars = nc;
152           n_bits = bits_per_char*n_chars;
153           n = divide(n_bits + bits_per_word - 1,bits_per_word,17,0);
154           bs = "0"b;
155           cs = "1"b;
156           reloc = "0"b;
157 
158           dt = char_string;
159           pc = addr(char_const);
160           go to join1;
161 
162 generate_constant$relocatable:          entry(pt,n_words,double) returns(ptr);
163 
164 dcl       pt ptr,                       /* pointer to relocatable constant */
165           double bit(1) aligned;        /* "1"b if constant should be on mod2_ boundary */
166 
167           /* entry point to generate relocatable constants for EIS descriptors
168              and constant argument lists containing ITP pairs for quick calls */
169 
170           n = n_words;
171           pc = pt;
172           bs, cs = "0"b;
173           reloc = "1"b;
174           dt = real_fix_bin_1;
175           go to join;
176 
177           end;