1
2
3
4
5
6
7
8
9
10
11 value: proc;
12
13 dcl en char (32) aligned int static,
14 dn char (168) aligned int static,
15 segptr ptr int static init (null),
16 ap ptr, al fixed bin, bchr char (al) unal based (ap),
17 answer char (32) varying,
18 bvcs char (al) varying based (ap),
19 ec fixed bin,
20 i fixed bin,
21 string char (168) aligned;
22
23 dcl (null, substr, addr, min) builtin;
24
25 dcl com_err_ entry options (variable),
26 adjust_bit_count_ entry (char (*) aligned, char (*) aligned, bit (1), fixed bin (24), fixed bin (17)),
27 get_wdir_ entry () returns (char (168) aligned),
28 expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin),
29 active_fnc_err_ entry options (variable),
30 cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
31 cu_$af_arg_count entry (fixed bin, fixed bin),
32 cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin),
33 cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin),
34 error_table_$wrong_no_of_args fixed bin ext,
35 hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned,
36 fixed bin (1), fixed bin (2), ptr, fixed bin),
37 hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned,
38 fixed bin (5), ptr, fixed bin),
39 ioa_ entry options (variable);
40
41 dcl 1 valueseg based (segptr) aligned,
42 2 laste fixed bin,
43 2 freep fixed bin,
44 2 pad (6) fixed bin,
45 2 arry (14506),
46 3 name char (32),
47 3 valu char (32),
48 3 lth fixed bin,
49 3 chain fixed bin;
50
51
52
53 if segptr = null then do;
54
55 dn = get_wdir_ ();
56 en = "value_seg";
57 call hcs_$initiate (dn, en, "", 0, 1, segptr, ec);
58 if segptr = null then do;
59 aer: call active_fnc_err_ (ec, "value", "^a>^a", dn, en);
60 return;
61 end;
62 end;
63
64 call cu_$af_arg_count (i, ec);
65 if ec ^= 0 then go to aer;
66 if i ^= 1 then do;
67 ec = error_table_$wrong_no_of_args;
68 go to aer;
69 end;
70 call cu_$af_arg_ptr (1, ap, al, ec);
71 if ec ^= 0 then go to aer;
72
73 do i = 1 to laste;
74 if chain (i) = 0 then if name (i) ^= "" then
75 if bchr = name (i) then go to found;
76 end;
77 answer = "undefined!";
78 go to give;
79
80 found: answer = substr (valu (i), 1, lth (i));
81 give: call cu_$af_return_arg (i, ap, al, ec);
82 if ec ^= 0 then go to aer;
83 bvcs = answer;
84 return;
85
86
87
88 set: entry;
89
90 if segptr = null then do;
91 dn = get_wdir_ ();
92 en = "value_seg";
93 call hcs_$initiate (dn, en, "", 0, 1, segptr, ec);
94 if segptr = null then do;
95 er: call com_err_ (ec, "value", "^a>^a", dn, en);
96 return;
97 end;
98 end;
99
100 call cu_$arg_ptr (1, ap, al, ec);
101 if ec ^= 0 then go to er;
102 string = bchr;
103
104 call cu_$arg_ptr (2, ap, al, ec);
105 if ec ^= 0 then do;
106 do i = 1 to laste;
107 if string = name (i) then do;
108 chain (i) = freep;
109 freep = i;
110 name (i) = "";
111 end;
112 end;
113 return;
114 end;
115
116 do i = 1 to laste;
117 if chain (i) = 0 then if name (i) ^= "" then
118 if name (i) = string then do;
119 go to f1;
120 end;
121 end;
122 if freep = 0 then i, laste = laste + 1;
123 else do;
124 i = freep;
125 freep = chain (i);
126 end;
127 name (i) = string;
128 f1: valu (i) = bchr;
129 chain (i) = 0;
130 lth (i) = min (al, 32);
131
132 call adjust_bit_count_ (dn, en, "0"b, (0), ec);
133
134 return;
135
136
137
138 set_seg: entry;
139
140 call cu_$arg_ptr (1, ap, al, ec);
141 if ec ^= 0 then go to er;
142 string = bchr;
143 call expand_path_ (addr (string), al, addr (dn), addr (en), ec);
144 if ec ^= 0 then go to er;
145 call hcs_$initiate (dn, en, "", 0, 1, segptr, ec);
146 if segptr = null then do;
147 call hcs_$make_seg (dn, en, "", 1011b, segptr, ec);
148 if segptr = null then go to er;
149 call ioa_ ("value: Creating ^a>^a", dn, en);
150 end;
151 return;
152
153
154
155 dump: entry;
156
157 if segptr = null then do;
158 dn = get_wdir_ ();
159 en = "value_seg";
160 call hcs_$initiate (dn, en, "", 0, 1, segptr, ec);
161 if segptr = null then go to er;
162 end;
163
164 call cu_$arg_ptr (1, ap, al, ec);
165 do i = 1 to laste;
166 if name (i) = "" then go to nop;
167 if chain (i) = 0 then do;
168 if ec = 0 then if name (i) ^= bchr then go to nop;
169 call ioa_ ("^-^a^-^a", name (i), substr (valu (i), 1, lth (i)));
170 end;
171 nop: end;
172 call ioa_ ("");
173
174 end;