1 inquire_lock_:
2 proc;
3
4
5
6
7
8
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
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
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
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;
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
79 call set_lock_$lock (inquire_locks.write_lock, 30, code);
80 if code ^= 0 then do;
81 if 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;
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;
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;
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
106 cur_lock_ptr = addr (inquire_locks.write_lock);
107 locked_for_writing = P_writing;
108 return;
109
110 wait: call timer_manager_$sleep (1, "11"b);
111 end;
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;
117 if inquire_locks.read_locks (i) = (36)"0"b then do;
118 call set_lock_$lock (inquire_locks.read_locks (i), 0, code);
119 cur_lock_ptr = addr (inquire_locks.read_locks (i));
120 locked_for_writing = P_writing;
121 call set_lock_$unlock (inquire_locks.write_lock, (0));
122 return;
123 end;
124 end;
125 P_code = inquire_et_$db_busy;
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