1
2
3
4
5
6
7
8
9
10 exist_any: proc;
11
12
13
14
15
16
17
18
19
20
21
22 dcl cu_$af_arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
23 cu_$af_return_arg ext entry (fixed bin, ptr, fixed bin, fixed bin (35));
24 dcl nargs fixed bin,
25 ai fixed bin,
26 ap ptr,
27 al fixed bin,
28 tp ptr,
29 tl fixed bin,
30 tfval char (tl) varying based (tp);
31
32 dcl expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
33
34 dcl hcs_$star_ ext entry (char (*), char (*), fixed bin (2), ptr,
35 fixed bin, ptr, ptr, fixed bin (35));
36
37 dcl (error_table_$nomatch,
38 error_table_$noarg,
39 error_table_$seg_not_found) fixed bin (35) static external;
40
41
42 dcl dir char (168),
43 starname char (32),
44 ecount fixed bin,
45 (eptr, nptr) pointer init (null ()),
46 ercd fixed bin (35);
47
48 dcl pname char (al) based (ap);
49
50 dcl active_fnc_err_ ext entry options (variable);
51
52
53
54
55
56 dcl areap ptr,
57 get_system_free_area_ entry () returns (ptr),
58 freen_ entry (ptr),
59 cleanup condition;
60
61 dcl (addr, null) builtin;
62
63
64
65
66
67
68 call cu_$af_return_arg (nargs, tp, tl, ercd);
69 if ercd ^= 0 then do;
70 call active_fnc_err_ (ercd, "exist_any");
71 return;
72 end;
73 else if nargs < 1 then do;
74 call active_fnc_err_ (error_table_$noarg, "exist_any", "segment name");
75 return;
76 end;
77
78
79
80 argloop: do ai = 1 to nargs;
81 call cu_$af_arg_ptr (ai, ap, al, ercd);
82
83
84 call expand_path_ (ap, al, addr (dir), addr (starname), ercd);
85 if ercd ^= 0 then do;
86 call active_fnc_err_ (ercd, "exist_any", pname);
87 return;
88 end;
89
90
91 areap = get_system_free_area_ ();
92 on condition (cleanup) go to cret;
93
94
95 call hcs_$star_ (dir, starname, 11b, areap, ecount, eptr, nptr, ercd);
96 if ercd = 0 then do;
97
98 if ecount ^= 0 then do;
99 tfval = "true";
100 go to cret;
101 end;
102 end;
103 else if ercd = error_table_$nomatch then;
104 else if ercd = error_table_$seg_not_found then ;
105 else do;
106 call active_fnc_err_ (ercd, "exist_any", pname);
107 go to cret;
108 end;
109
110 end argloop;
111
112 false:
113 tfval = "false";
114
115
116 cret:
117 if eptr ^= null () then call freen_ (eptr);
118 if nptr ^= null () then call freen_ (nptr);
119 return;
120
121 end exist_any;