1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18 linus_declare:
19 proc (sci_ptr, lcb_ptr);
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50 ^L
51 %include linus_lcb;
52 %page;
53 %include linus_char_argl;
54 %page;
55 %include linus_scal_fn_info;
56 ^L
57 dcl sci_ptr ptr;
58
59 dcl (
60 code,
61 icode
62 ) fixed bin (35);
63
64 dcl initial_mrds_vclock float bin (63);
65
66 dcl name char (char_argl.arg.arg_len (1)) based (char_argl.arg.arg_ptr (1));
67
68 dcl type char (char_argl.arg.arg_len (2)) based (char_argl.arg.arg_ptr (2));
69
70 dcl file_name char (168) varying;
71
72 dcl (directory, entry_name) char (168);
73
74 dcl (
75 linus_data_$dcl_id,
76 linus_error_$bad_num_args,
77 linus_error_$inv_fn_type,
78 linus_error_$no_db,
79 sys_info$max_seg_size
80 ) fixed bin (35) ext;
81
82 dcl cleanup condition;
83
84 dcl (addr, fixed, null, rel, rtrim, vclock) builtin;
85
86 dcl calc_entry entry variable;
87
88 dcl cv_entry_ entry (char (*), ptr, fixed bin (35)) returns (entry);
89 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
90 dcl dsl_$declare entry (fixed bin (35), char (*), fixed bin (35));
91 dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35));
92 dcl linus_thread_fn_list
93 entry (ptr, entry, char (168) varying, char (32) varying,
94 fixed bin (35));
95 dcl ssu_$abort_line entry options (variable);
96 dcl ssu_$arg_count entry (ptr, fixed bin);
97 dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
98 ^L
99 sclfi_ptr, ca_ptr = null;
100 on cleanup call tidy_up;
101
102 if lcb.db_index = 0 then
103 call error (linus_error_$no_db, "");
104 call ssu_$arg_count (sci_ptr, nargs_init);
105 if nargs_init = 0 then
106 call error (linus_error_$bad_num_args, "");
107 if nargs_init ^= 2 then
108 call error (linus_error_$bad_num_args, "");
109 allocate char_argl in (lcb.static_area);
110 call ssu_$arg_ptr (sci_ptr, 1, char_argl.arg.arg_ptr (1), char_argl.arg.arg_len (1));
111 call ssu_$arg_ptr (sci_ptr, 2, char_argl.arg.arg_ptr (2), char_argl.arg.arg_len (2));
112 file_name = rtrim (name);
113
114 if type = "set" then do;
115 call expand_pathname_ (name, directory, entry_name, icode);
116 if icode ^= 0 then
117 call error (icode, name);
118 calc_entry =
119 cv_entry_ (rtrim (directory) || ">" || rtrim (entry_name) || "$"
120 || rtrim (entry_name) || "_calc", null, icode);
121 if icode ^= 0 then
122 call error (icode, file_name || " calc. entry.");
123 call
124 linus_thread_fn_list (lcb_ptr, calc_entry, file_name,
125 rtrim (entry_name), icode);
126 if icode ^= 0 then
127 call error (icode, name);
128 end;
129
130 else if type = "scalar" then do;
131 if lcb.timing_mode then
132 initial_mrds_vclock = vclock;
133 call dsl_$declare (lcb.db_index, name, icode);
134 if lcb.timing_mode then
135 lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock;
136 if icode ^= 0 then
137 call error (icode, name);
138 allocate scal_fn_info in (lcb.static_area);
139 scal_fn_info.name = rtrim (entry_name);
140 scal_fn_info.fwd_ptr = lcb.sclfi_ptr;
141 lcb.sclfi_ptr = sclfi_ptr;
142 end;
143 else call error (linus_error_$inv_fn_type, type);
144
145 if ca_ptr ^= null
146 then free char_argl;
147 return;
148 ^L
149 error:
150 proc (cd, msg);
151
152
153
154 dcl (cd, ucd) fixed bin (35);
155
156 dcl msg char (*);
157
158 call tidy_up;
159 call linus_convert_code (cd, ucd, linus_data_$dcl_id);
160 call ssu_$abort_line (sci_ptr, ucd, msg);
161
162 end error;
163 ^L
164 tidy_up:
165 proc;
166
167
168
169 if sclfi_ptr ^= null then
170 if sclfi_ptr ^= lcb.sclfi_ptr then
171 free scal_fn_info;
172 if ca_ptr ^= null
173 then free char_argl;
174
175 end tidy_up;
176
177 end linus_declare;