1
2
3
4
5
6
7
8
9
10
11
12
13
14 signal:
15 procedure options (variable);
16
17
18
19
20 declare signal_ entry (character (*), pointer, pointer, pointer);
21 declare com_err_ entry () options (variable);
22 declare cu_$arg_count entry (fixed bin, fixed bin (35));
23 declare cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
24
25 declare cv_ptr_ entry (character (*), fixed binary (35)) returns (pointer);
26 declare cv_ptr_$terminate entry (pointer);
27
28 declare argument_count fixed bin;
29 declare argument_ptr pointer;
30 declare argument_length fixed bin (21);
31 declare argument character (argument_length) based (argument_ptr);
32 declare argx fixed bin;
33
34 declare error_ptr pointer;
35 declare error_name character (256);
36 declare based_error_code fixed bin (35) based (error_ptr);
37
38 %include condition_info_header;
39 declare 1 cih aligned like condition_info_header;
40
41 declare condition_name character (256);
42 declare code fixed bin (35);
43
44 declare (
45 error_table_$badopt,
46 error_table_$too_many_args,
47 error_table_$noarg
48 ) fixed bin (35) external static;
49 declare ME character (32) init ("signal") internal static options (constant);
50 declare cleanup condition;
51 declare (unspec, substr, null, currentsize)
52 builtin;
53 ^L
54
55 call cu_$arg_count (argument_count, code);
56 if code ^= 0
57 then do;
58 call com_err_ (code, ME);
59 return;
60 end;
61
62 if argument_count = 0
63 then do;
64 call com_err_ (0, ME, "Usage: signal CONDITION -control_args");
65 return;
66 end;
67
68 error_ptr = null;
69 on cleanup
70 begin;
71 if error_ptr ^= null
72 then call cv_ptr_$terminate (error_ptr);
73 end;
74 condition_name = "";
75 unspec (cih) = ""b;
76 cih.version = 1;
77 cih.info_string = " ";
78 cih.length = currentsize (cih);
79
80 do argx = 1 to argument_count;
81 call cu_$arg_ptr (argx, argument_ptr, argument_length, (0));
82 if substr (argument, 1, 1) ^= "-"
83 then do;
84 if condition_name ^= ""
85 then do;
86 call com_err_ (error_table_$too_many_args, ME, "Only one condition name may be given.")
87 ;
88 return;
89 end;
90 condition_name = argument;
91 end;
92 else if argument = "-info_string"
93 then do;
94 if cih.info_string ^= ""
95 then do;
96 call com_err_ (error_table_$too_many_args, ME, "Only one info_string may be given.");
97 go to RETURN;
98 end;
99 if argx = argument_count
100 then do;
101 nostring:
102 call com_err_ (error_table_$noarg, ME,
103 "An info string must be supplied with -info_string.");
104 go to RETURN;
105 end;
106 argx = argx + 1;
107 call cu_$arg_ptr (argx, argument_ptr, argument_length, (0));
108 if substr (argument, 1, 1) = "-"
109 then go to nostring;
110 cih.info_string = argument;
111 end;
112 else if argument = "-code"
113 then do;
114 if argx = argument_count
115 then do;
116 nocode:
117 call com_err_ (error_table_$noarg, ME,
118 "An error table code must be supplied with -code.");
119 go to RETURN;
120 end;
121 argx = argx + 1;
122 call cu_$arg_ptr (argx, argument_ptr, argument_length, (0));
123 if substr (argument, 1, 1) = "-"
124 then goto nocode;
125
126 if index (argument, "$") = 0
127 then error_name = "error_table_$" || argument;
128 else error_name = argument;
129 error_ptr = cv_ptr_ (error_name, code);
130 if code ^= 0
131 then do;
132 call com_err_ (code, ME, "^a", error_name);
133 return;
134 end;
135 cih.status_code = based_error_code;
136 end;
137 else if argument = "-cant_restart"
138 then cih.cant_restart = "1"b;
139 else if argument = "-default_restart"
140 then cih.default_restart = "1"b;
141 else if argument = "-quiet_restart"
142 then cih.quiet_restart = "1"b;
143 else if argument = "-support_signal"
144 then cih.support_signal = "1"b;
145 else do;
146 call com_err_ (error_table_$badopt, ME, "^a", argument);
147 go to RETURN;
148 end;
149 end;
150
151 if condition_name = ""
152 then do;
153 call com_err_ (error_table_$noarg, ME, "A condition name must be given.");
154 RETURN:
155 if error_ptr ^= null
156 then call cv_ptr_$terminate (error_ptr);
157 return;
158 end;
159
160 call signal_ (condition_name, null, addr (cih), null);
161 go to RETURN;
162
163 end signal;