1 inquire_lock_:
  2      proc;
  3 
  4      /*** This procedure maintains the locks for the Inquire database,
  5              as MRDS locking doesn't work in inner rings (hopefully this
  6              will). ***/
  7 
  8           /*** External Entries ***/
  9 
 10           dcl     hcs_$initiate          entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
 11           dcl     timer_manager_$sleep   entry (fixed bin (71), bit (2));
 12           dcl     set_lock_$lock         entry (bit (36) aligned, fixed bin, fixed bin (35));
 13           dcl     set_lock_$unlock       entry (bit (36) aligned, fixed bin (35));
 14 
 15           /*** External constants ***/
 16 
 17           dcl     inquire_lock_data_$lock_seg_dir
 18                                          char (168) external;
 19           dcl     inquire_lock_data_$lock_seg_entry
 20                                          char (32) external;
 21           dcl     inquire_lock_data_$read_lock_count
 22                                          fixed bin (21) external;
 23           dcl     (inquire_et_$int_error_no_lock,
 24                   inquire_et_$bad_recursion,
 25                   inquire_et_$db_busy,
 26                   error_table_$locked_by_this_process,
 27                   error_table_$lock_not_locked,
 28                   error_table_$locked_by_other_process,
 29                   error_table_$lock_wait_time_exceeded,
 30                   error_table_$invalid_lock_reset)
 31                                          fixed bin (35) external static;
 32 
 33           /*** Internal static and based ***/
 34 
 35           dcl     locked_for_writing     bit (1) internal static;
 36           dcl     locks_ptr              ptr internal static;
 37           dcl     1 inquire_locks        based (locks_ptr),
 38                     2 write_lock         bit (36) aligned,
 39                     2 read_locks         (inquire_lock_data_$read_lock_count)
 40                                          bit (36) aligned;
 41           dcl     cur_lock_ptr           ptr internal static;
 42           dcl     cur_lock               bit (36) aligned based (cur_lock_ptr);
 43 
 44           /*** Automatic, etc. ***/
 45 
 46           dcl     code                   fixed bin (35);
 47           dcl     (i, j)                 fixed bin;
 48           dcl     cleanup                condition;
 49 
 50           dcl     P_code                 fixed bin (35) parameter;
 51           dcl     P_writing              bit (1) parameter; /* "1"b if locking for write */
 52 ^L
 53 init: entry (P_code);
 54 
 55           cur_lock_ptr = null ();
 56           locks_ptr = null ();
 57           call hcs_$initiate (inquire_lock_data_$lock_seg_dir,
 58                inquire_lock_data_$lock_seg_entry,
 59                "", 0, 0, locks_ptr,
 60                (0));
 61           if locks_ptr = null () then P_code = inquire_et_$int_error_no_lock;
 62           else P_code = 0;
 63 
 64           return;
 65 ^L
 66 lock: entry (P_writing, P_code);
 67 
 68           P_code = 0;
 69 
 70           if cur_lock_ptr ^= null () then do;
 71                     P_code = inquire_et_$bad_recursion;
 72                     return;
 73 
 74                end;
 75 
 76           on cleanup call set_lock_$unlock (inquire_locks.write_lock, (0));
 77 
 78           /*** First grab the write lock ***/
 79           call set_lock_$lock (inquire_locks.write_lock, 30, code);
 80           if code ^= 0 then do;
 81                     if /* case */ code = error_table_$locked_by_this_process then P_code = inquire_et_$bad_recursion;
 82                     else if code = error_table_$invalid_lock_reset then P_code = 0; /* MRDS should take care of this conflict (I hope) */
 83                     else if code = error_table_$lock_wait_time_exceeded then P_code = inquire_et_$db_busy;
 84                     else P_code = code;
 85                     return;
 86                end;
 87 
 88           if P_writing then do;
 89                     do i = 1 to 30;
 90                          do j = 1 to inquire_lock_data_$read_lock_count; /* Check if any are valid */
 91                               if inquire_locks.read_locks (j) ^= (36)"0"b then do;
 92                                         call set_lock_$lock (inquire_locks.read_locks (j), 0, code);
 93                                         if code = error_table_$lock_wait_time_exceeded then go to wait; /* there is still a reader in */
 94                                         else if code = error_table_$locked_by_this_process then do;
 95                                                   P_code = inquire_et_$bad_recursion;
 96                                                   go to unlock_and_exit;
 97                                              end;
 98                                         else if code ^= 0 & code ^= error_table_$invalid_lock_reset then do;
 99                                                   P_code = code;
100                                                   go to unlock_and_exit;
101                                              end;
102                                         else call set_lock_$unlock (inquire_locks.read_locks (j), (0));
103                                    end;
104                          end;
105                          /*** We made it through all of them ***/
106                          cur_lock_ptr = addr (inquire_locks.write_lock);
107                          locked_for_writing = P_writing;    /* Save it for unlock */
108                          return;                            /* Leave write lock locked */
109 
110 wait:                    call timer_manager_$sleep (1, "11"b); /* 1 second relative */
111                     end;                                    /** do **/
112                     P_code = inquire_et_$db_busy;
113                     go to unlock_and_exit;
114                end;
115 
116           else do i = 1 to inquire_lock_data_$read_lock_count; /* reading */
117                     if inquire_locks.read_locks (i) = (36)"0"b then do; /* Find a free read lock */
118                               call set_lock_$lock (inquire_locks.read_locks (i), 0, code); /* Grab it */
119                               cur_lock_ptr = addr (inquire_locks.read_locks (i));
120                               locked_for_writing = P_writing; /* Save it for unlock */
121                               call set_lock_$unlock (inquire_locks.write_lock, (0));
122                               return;
123                          end;
124                end;
125           P_code = inquire_et_$db_busy;                     /* No room in reader table */
126 
127 unlock_and_exit:
128           call set_lock_$unlock (inquire_locks.write_lock, (0));
129 
130           return;
131 ^L
132 unlock: entry (P_code);
133 
134           P_code = 0;
135           if cur_lock_ptr = null () then do;
136                     P_code = error_table_$lock_not_locked;
137                     return;
138                end;
139           call set_lock_$unlock (cur_lock, code);
140           if code ^= 0 then do;
141                     P_code = code;
142                     return;
143                end;
144 
145           cur_lock_ptr = null ();
146           return;
147 
148 
149      end inquire_lock_;
150