1 %page;
  2 
  3 /* *      STRUCTURE_LIBRARY_CODE.INCL.PL1
  4    *
  5    *      This procedure generates the default library segment for the
  6    *      structure display system.  The way it operates is hardly what one
  7    *      would call normal, however. It has to do a number of rather unclean
  8    *      things, and modifications must be made carefully following these
  9    *      conventions:
 10    *
 11    *      Because the compiler insists on actually having a structure appear
 12    *      in some reference context for it to appear in the symbol table,
 13    *      regardless of options, every structure defined herein must be
 14    *      referenced somehow. This is accomplished with the calls to the
 15    *      "add" procedure. The first argument to the "add" procedure is the
 16    *      name of the structure, put there so it can be added to the table
 17    *      of contents for the segment.
 18    *
 19    *      The second argument to the add procedure is a pointer, which must
 20    *      always be of the form "addr (p -> structure)".  This is done to
 21    *      that the structure will be referenced, while at the same time
 22    *      avoiding any reference to its implicit base, or to other values
 23    *      which must be initialized to avoid warnings.
 24    *
 25    *      Finally, this program compiles and runs itself using
 26    *      create_data_segment; this is done both to ensure that it gets
 27    *      compiled with a symbol table, and to make it possible copy the
 28    *      object segment and write into the internal static options (constant)
 29    *      array that is the table of structures. All in all, it's pretty
 30    *      complicated.
 31    *
 32    *      The code for this program is in an include file in order to ease
 33    *      the construction of user-defined structure libraries. In order to
 34    *      use this code, one must create a program looking like this:
 35    *
 36    *      structure_library_7_:
 37    *           procedure ();
 38    *
 39    *                < %include statements, calls to add >
 40    *
 41    *       dcl  WHOAMI char (32) internal static options (constant) init ("structure_library_7_");
 42    *      %include structure_library_code;
 43    *                end structure_library_7_;
 44    *
 45    *      The standard structure libraries (structure_library_1_.cds,
 46    *      for example, provide a good example of this.
 47    *
 48    *      30 May 1983, W. Olin Sibert
 49    */
 50 
 51 /* ^L */
 52 
 53 /* Now come the more ordinary parts of code that usually appear in a program */
 54 
 55 dcl  code fixed binary (35);
 56 dcl  severity_ptr pointer;
 57 dcl  severity_value fixed bin (35) based (severity_ptr);
 58 dcl  answer bit (1) aligned;
 59 dcl  new_segp pointer;
 60 dcl  old_segp pointer;
 61 dcl  bitcount fixed bin (24);
 62 dcl  n_words fixed bin (18);
 63 dcl  based_words (n_words) bit (36) aligned based;
 64 
 65 dcl  p pointer init (null ());                              /* our general-purpose base */
 66 
 67 dcl  com_err_ entry options (variable);
 68 dcl  command_query_$yes_no entry options (variable);
 69 dcl  get_external_variable_ entry (char (*), pointer, fixed bin (19), pointer, fixed bin (35));
 70 dcl  get_wdir_ entry () returns (char (168));
 71 dcl  hcs_$make_seg entry (char (*), char (*), char (*),
 72      fixed bin (5), pointer, fixed bin (35));
 73 dcl  hcs_$set_bc_seg entry (pointer, fixed bin (24), fixed bin (35));
 74 dcl  hcs_$status_mins entry
 75     (pointer, fixed bin (2), fixed bin (24), fixed bin (35));
 76 dcl  hcs_$terminate_noname entry (pointer, fixed bin (35));
 77 dcl  nothing entry options (variable);
 78 
 79 dcl  INITIALIZED bit (1) aligned internal static options (constant) init ("0"b);
 80 dcl  initialized_bit bit (1) aligned based;
 81 
 82 /* The following array is important: it defines the "table of contents"
 83    for the structure library segment.  It is declared and initialized to
 84    empty, but when the object segment is copied into the library segment,
 85    it is filled in with the actual names of all the structures, which were
 86    collected by all the calls to "add", above. */
 87 
 88 dcl  STRUCTURES (200) char (32) unaligned internal static options (constant)
 89      init ((200)(32)"");
 90 
 91 /* This is the automatic array where the data is collected, and the based
 92    overlay used later on to copy it into the new segment */
 93 
 94 dcl  based_structures (n_structures) char (32) unaligned based;
 95 dcl  structures (hbound (STRUCTURES, 1)) char (32) unaligned automatic;
 96 dcl  n_structures fixed bin init (0);
 97 
 98 dcl (addr, codeptr, null, rel, size, unspec) builtin;
 99 
100 /*^L*/
101 
102 /* Finally, the real code, which copies one segment onto the other and
103    updates the structures arrays. */
104 
105           if INITIALIZED then do;
106                call com_err_ (0, WHOAMI, "This program is a data segment, and may not be executed.");
107                return;
108                end;
109 
110           call get_external_variable_ ("pl1_severity_", severity_ptr, (0), (null ()), code);
111           if (code ^= 0) then do;
112                call com_err_ (code,  WHOAMI, "Cannot determine severity for compilation of ^a.", WHOAMI);
113                return;
114                end;
115 
116           if (severity_value = 2) then do;
117                call command_query_$yes_no (answer, 0, WHOAMI,
118 
119 "ERROR 366 means that the program is too large to construct a symbol table;
120 this quite commonly happens to structure libraries because of their enormous
121 symbol tables. You may be able to fix the error by rearranging some of the
122 include files.",
123 
124 "Warning: A severity two PL/I error has occurred.
125 If it is ERROR 366, the result of this compilation will be partially invalid.
126 Do you wish to continue and generate the library segment anyway?");
127 
128                if ^answer then return;
129                end;
130 
131           old_segp = pointer (addr (STRUCTURES), 0);
132 
133           call hcs_$status_mins (old_segp, (0), bitcount, code);
134           if (code ^= 0) then do;
135                call com_err_ (code, WHOAMI,
136                     "Cannot get bitcount of original segment.");
137                return;
138                end;
139 
140           call hcs_$make_seg ((get_wdir_ ()), WHOAMI, "", 01010b, new_segp, code);
141           if (new_segp = null ()) then do;
142                call com_err_ (code, WHOAMI, "Cannot create [wd]>^a", WHOAMI);
143                return;
144                end;
145 
146           n_words = divide (bitcount, 36, 18, 0);
147           new_segp -> based_words = old_segp -> based_words;
148 
149           call hcs_$set_bc_seg (new_segp, bitcount, code);
150           if (code ^= 0) then do;
151                call com_err_ (code, WHOAMI,
152                     "Cannot set bitcount on [wd]>^a", WHOAMI);
153                return;
154                end;
155 
156 /* Finally, copy in the structure list */
157 
158           pointer (new_segp, rel (addr (STRUCTURES))) -> based_structures
159                = addr (structures) -> based_structures;
160           pointer (new_segp, rel (addr (INITIALIZED))) -> initialized_bit = "1"b;
161 
162           call hcs_$terminate_noname (new_segp, (0));
163 
164 ERROR_RETURN:
165           return;
166 
167 /* ^L */
168 
169 /* This is called once for each structure which goes in the table of contents.
170    It adds the structure to the automatic array, and increments the count. */
171 
172 add:
173 addx:
174      procedure (name, useless_pointer);
175 
176 dcl  name char (32);
177 dcl  useless_pointer pointer;
178 
179 /* The bounds check is against hbound - 1, since it is necessary to always
180    leave at least one blank entry in the table of contents to show where
181    the last valid entry is. */
182 
183 
184           if (n_structures >= (hbound (STRUCTURES, 1) - 1)) then do;
185                call com_err_ (0, WHOAMI,
186                     "Too many structures defined. Max is ^d.^/^3xChange the dimension of the STRUCTURES array and recompile.",
187                     hbound (STRUCTURES, 1));
188                goto ERROR_RETURN;
189                end;
190 
191           n_structures = n_structures + 1;
192           structures (n_structures) = name;
193           structures (n_structures + 1) = "";
194           return;
195           end add;