1 /*
2 Copyright (C) 2001-2020 Free Software Foundation, Inc.
3 Written by Keisuke Nishida, Roger While, Simon Sobisch, Ron Norman,
4 Edward Hart
5
6 This file is part of GnuCOBOL.
7
8 The GnuCOBOL compiler is free software: you can redistribute it
9 and/or modify it under the terms of the GNU General Public License
10 as published by the Free Software Foundation, either version 3 of the
11 License, or (at your option) any later version.
12
13 GnuCOBOL is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GnuCOBOL. If not, see <https://www.gnu.org/licenses/>.
20 */
21
22
23 #include <config.h>
24
25 #include <stdio.h>
26 #include <stdlib.h>
27 #include <stddef.h>
28 #include <string.h>
29 #include <ctype.h>
30 #include <time.h>
31 #include <limits.h>
32 #ifdef HAVE_SYS_TIME_H
33 #include <sys/time.h>
34 #endif
35 #ifdef _WIN32
36 #define WIN32_LEAN_AND_MEAN
37 #include <windows.h>
38 #endif
39
40 #ifdef HAVE_LOCALE_H
41 #include <locale.h>
42 #endif
43
44 #include "cobc.h"
45 #include "tree.h"
46
47 struct system_table {
48 const char *const syst_name;
49 const unsigned int syst_params_min;
50 const unsigned int syst_params_max;
51 };
52
53 struct optim_table {
54 const char *const optim_name;
55 const enum cb_optim optim_val;
56 };
57
58 struct expr_node {
59 /* The token of this node.
60 * 'x' - values (cb_tree)
61 * '+', '-', '*', '/', '^' - arithmetic operators
62 * '=', '~', '<', '>', '[', ']' - relational operators
63 * '!', '&', '|' - logical operators
64 * '(', ')' - parentheses
65 */
66 int token;
67 /* The value itself if this node is a value */
68 cb_tree value;
69 };
70
71 #define START_STACK_SIZE 32
72 #define TOKEN(offset) (expr_stack[expr_index + offset].token)
73 #define VALUE(offset) (expr_stack[expr_index + offset].value)
74
75 #define dpush(x) CB_ADD_TO_CHAIN (x, decimal_stack)
76
77 #define cb_emit(x) \
78 current_statement->body = cb_list_add (current_statement->body, x)
79 #define cb_emit_list(l) \
80 current_statement->body = cb_list_append (current_statement->body, l)
81
82 /* Global variables */
83
84 cb_tree cb_debug_item;
85 cb_tree cb_debug_line;
86 cb_tree cb_debug_name;
87 cb_tree cb_debug_sub_1;
88 cb_tree cb_debug_sub_2;
89 cb_tree cb_debug_sub_3;
90 cb_tree cb_debug_contents;
91
92 size_t suppress_warn = 0;
93
94 /* Local variables */
95
96 static cb_tree decimal_stack = NULL;
97
98 static const char *inspect_func;
99 static cb_tree inspect_data;
100 struct cb_statement *error_statement = NULL;
101
102 #if 0 /* pending merge of cb_warn_unsupported */
103 #ifndef WITH_XML2
104 static int warn_xml_done = 0;
105 #endif
106 #if !defined (WITH_CJSON) && !defined (WITH_JSON_C)
107 static int warn_json_done = 0;
108 #endif
109 #ifndef WITH_EXTENDED_SCREENIO
110 static int warn_screen_done = 0;
111 #endif
112 #endif
113 static int expr_op; /* Last operator */
114 static cb_tree expr_lh; /* Last left hand */
115 static int expr_dmax = -1; /* Max scale for expression result */
116 #define MAX_NESTED_EXPR 64
117 static cb_tree expr_x = NULL;
118 static int expr_dec_align = -1;
119 static int expr_nest = 0;
120 static int expr_decp[MAX_NESTED_EXPR];
121 static int cond_fixed = -1; /* 0 means TRUE, 1 means FALSE, -1 unknown */
122 #define MAX_NESTED_COND 128
123 static int if_nest = 0;
124 static int if_cond[MAX_NESTED_COND];
125 static int if_stop = 0;
126 static int expr_line = 0; /* Line holding expression for warnings */
127 static cb_tree expr_rslt = NULL; /* Expression result */
128
129 static size_t initialized = 0;
130 static size_t overlapping = 0;
131
132 static int expr_index; /* Stack index */
133 static int expr_stack_size; /* Stack max size */
134 static struct expr_node *expr_stack; /* Expression node stack */
135 static int report_id = 1;
136
137 #ifdef HAVE_DESIGNATED_INITS
138 static const unsigned char expr_prio[256] = {
139 ['x'] = 0,
140 ['^'] = 1,
141 ['*'] = 2,
142 ['/'] = 2,
143 ['+'] = 3,
144 ['-'] = 3,
145 ['='] = 4,
146 ['~'] = 4,
147 ['<'] = 4,
148 ['>'] = 4,
149 ['['] = 4,
150 [']'] = 4,
151 ['!'] = 5,
152 ['&'] = 6,
153 ['|'] = 7,
154 [')'] = 8,
155 ['('] = 9,
156 [0] = 10
157 };
158 #else
159 static unsigned char expr_prio[256];
160 #endif
161
162 #ifdef COB_EBCDIC_MACHINE
163 /* EBCDIC referring to ASCII */
164 static const unsigned char cob_refer_ascii[256] = {
165 0x00, 0x01, 0x02, 0x03, 0x37, 0x2D, 0x2E, 0x2F,
166 0x16, 0x05, 0x25, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
167 0x10, 0x11, 0x12, 0x13, 0x3C, 0x3D, 0x32, 0x26,
168 0x18, 0x19, 0x3F, 0x27, 0x1C, 0x1D, 0x1E, 0x1F,
169 0x40, 0x5A, 0x7F, 0x7B, 0x5B, 0x6C, 0x50, 0x7D,
170 0x4D, 0x5D, 0x5C, 0x4E, 0x6B, 0x60, 0x4B, 0x61,
171 0xF0, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7,
172 0xF8, 0xF9, 0x7A, 0x5E, 0x4C, 0x7E, 0x6E, 0x6F,
173 0x7C, 0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7,
174 0xC8, 0xC9, 0xD1, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6,
175 0xD7, 0xD8, 0xD9, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6,
176 0xE7, 0xE8, 0xE9, 0xAD, 0xE0, 0xBD, 0x5F, 0x6D,
177 0x79, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,
178 0x88, 0x89, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96,
179 0x97, 0x98, 0x99, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6,
180 0xA7, 0xA8, 0xA9, 0xC0, 0x6A, 0xD0, 0xA1, 0x07,
181 0x68, 0xDC, 0x51, 0x42, 0x43, 0x44, 0x47, 0x48,
182 0x52, 0x53, 0x54, 0x57, 0x56, 0x58, 0x63, 0x67,
183 0x71, 0x9C, 0x9E, 0xCB, 0xCC, 0xCD, 0xDB, 0xDD,
184 0xDF, 0xEC, 0xFC, 0xB0, 0xB1, 0xB2, 0x3E, 0xB4,
185 0x45, 0x55, 0xCE, 0xDE, 0x49, 0x69, 0x9A, 0x9B,
186 0xAB, 0x9F, 0xBA, 0xB8, 0xB7, 0xAA, 0x8A, 0x8B,
187 0xB6, 0xB5, 0x62, 0x4F, 0x64, 0x65, 0x66, 0x20,
188 0x21, 0x22, 0x70, 0x23, 0x72, 0x73, 0x74, 0xBE,
189 0x76, 0x77, 0x78, 0x80, 0x24, 0x15, 0x8C, 0x8D,
190 0x8E, 0x41, 0x06, 0x17, 0x28, 0x29, 0x9D, 0x2A,
191 0x2B, 0x2C, 0x09, 0x0A, 0xAC, 0x4A, 0xAE, 0xAF,
192 0x1B, 0x30, 0x31, 0xFA, 0x1A, 0x33, 0x34, 0x35,
193 0x36, 0x59, 0x08, 0x38, 0xBC, 0x39, 0xA0, 0xBF,
194 0xCA, 0x3A, 0xFE, 0x3B, 0x04, 0xCF, 0xDA, 0x14,
195 0xE1, 0x8F, 0x46, 0x75, 0xFD, 0xEB, 0xEE, 0xED,
196 0x90, 0xEF, 0xB3, 0xFB, 0xB9, 0xEA, 0xBB, 0xFF
197 };
198 #else
199 /* ASCII referring to EBCDIC */
200 static const unsigned char cob_refer_ebcdic[256] = {
201 0x00, 0x01, 0x02, 0x03, 0xEC, 0x09, 0xCA, 0x7F,
202 0xE2, 0xD2, 0xD3, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
203 0x10, 0x11, 0x12, 0x13, 0xEF, 0xC5, 0x08, 0xCB,
204 0x18, 0x19, 0xDC, 0xD8, 0x1C, 0x1D, 0x1E, 0x1F,
205 0xB7, 0xB8, 0xB9, 0xBB, 0xC4, 0x0A, 0x17, 0x1B,
206 0xCC, 0xCD, 0xCF, 0xD0, 0xD1, 0x05, 0x06, 0x07,
207 0xD9, 0xDA, 0x16, 0xDD, 0xDE, 0xDF, 0xE0, 0x04,
208 0xE3, 0xE5, 0xE9, 0xEB, 0x14, 0x15, 0x9E, 0x1A,
209 0x20, 0xC9, 0x83, 0x84, 0x85, 0xA0, 0xF2, 0x86,
210 0x87, 0xA4, 0xD5, 0x2E, 0x3C, 0x28, 0x2B, 0xB3,
211 0x26, 0x82, 0x88, 0x89, 0x8A, 0xA1, 0x8C, 0x8B,
212 0x8D, 0xE1, 0x21, 0x24, 0x2A, 0x29, 0x3B, 0x5E,
213 0x2D, 0x2F, 0xB2, 0x8E, 0xB4, 0xB5, 0xB6, 0x8F,
214 0x80, 0xA5, 0x7C, 0x2C, 0x25, 0x5F, 0x3E, 0x3F,
215 0xBA, 0x90, 0xBC, 0xBD, 0xBE, 0xF3, 0xC0, 0xC1,
216 0xC2, 0x60, 0x3A, 0x23, 0x40, 0x27, 0x3D, 0x22,
217 0xC3, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67,
218 0x68, 0x69, 0xAE, 0xAF, 0xC6, 0xC7, 0xC8, 0xF1,
219 0xF8, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70,
220 0x71, 0x72, 0xA6, 0xA7, 0x91, 0xCE, 0x92, 0xA9,
221 0xE6, 0x7E, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78,
222 0x79, 0x7A, 0xAD, 0xA8, 0xD4, 0x5B, 0xD6, 0xD7,
223 0x9B, 0x9C, 0x9D, 0xFA, 0x9F, 0xB1, 0xB0, 0xAC,
224 0xAB, 0xFC, 0xAA, 0xFE, 0xE4, 0x5D, 0xBF, 0xE7,
225 0x7B, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47,
226 0x48, 0x49, 0xE8, 0x93, 0x94, 0x95, 0xA2, 0xED,
227 0x7D, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50,
228 0x51, 0x52, 0xEE, 0x96, 0x81, 0x97, 0xA3, 0x98,
229 0x5C, 0xF0, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58,
230 0x59, 0x5A, 0xFD, 0xF5, 0x99, 0xF7, 0xF6, 0xF9,
231 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37,
232 0x38, 0x39, 0xDB, 0xFB, 0x9A, 0xF4, 0xEA, 0xFF
233 };
234 #endif
235
236 /* System routines */
237
238 #undef COB_SYSTEM_GEN
239 #define COB_SYSTEM_GEN(cob_name, pmin, pmax, c_name) { cob_name, pmin, pmax },
240
241 static const struct system_table system_tab[] = {
242 #include "libcob/system.def"
243 { NULL, 0, 0 }
244 };
245
246 #undef COB_SYSTEM_GEN
247
248 static const struct optim_table bin_set_funcs[] = {
249 { NULL, COB_OPTIM_MIN },
250 { "cob_setswp_u16", COB_SETSWP_U16 },
251 { "cob_setswp_u24", COB_SETSWP_U24 },
252 { "cob_setswp_u32", COB_SETSWP_U32 },
253 { "cob_setswp_u40", COB_SETSWP_U40 },
254 { "cob_setswp_u48", COB_SETSWP_U48 },
255 { "cob_setswp_u56", COB_SETSWP_U56 },
256 { "cob_setswp_u64", COB_SETSWP_U64 },
257 { NULL, COB_OPTIM_MIN },
258 { "cob_setswp_s16", COB_SETSWP_S16 },
259 { "cob_setswp_s24", COB_SETSWP_S24 },
260 { "cob_setswp_s32", COB_SETSWP_S32 },
261 { "cob_setswp_s40", COB_SETSWP_S40 },
262 { "cob_setswp_s48", COB_SETSWP_S48 },
263 { "cob_setswp_s56", COB_SETSWP_S56 },
264 { "cob_setswp_s64", COB_SETSWP_S64 }
265 };
266
267 static const struct optim_table bin_compare_funcs[] = {
268 { "cob_cmp_u8", COB_CMP_U8 },
269 { "cob_cmp_u16", COB_CMP_U16 },
270 { "cob_cmp_u24", COB_CMP_U24 },
271 { "cob_cmp_u32", COB_CMP_U32 },
272 { "cob_cmp_u40", COB_CMP_U40 },
273 { "cob_cmp_u48", COB_CMP_U48 },
274 { "cob_cmp_u56", COB_CMP_U56 },
275 { "cob_cmp_u64", COB_CMP_U64 },
276 { "cob_cmp_s8", COB_CMP_S8 },
277 { "cob_cmp_s16", COB_CMP_S16 },
278 { "cob_cmp_s24", COB_CMP_S24 },
279 { "cob_cmp_s32", COB_CMP_S32 },
280 { "cob_cmp_s40", COB_CMP_S40 },
281 { "cob_cmp_s48", COB_CMP_S48 },
282 { "cob_cmp_s56", COB_CMP_S56 },
283 { "cob_cmp_s64", COB_CMP_S64 },
284 { "cob_cmp_u8", COB_CMP_U8 },
285 { "cob_cmpswp_u16", COB_CMPSWP_U16 },
286 { "cob_cmpswp_u24", COB_CMPSWP_U24 },
287 { "cob_cmpswp_u32", COB_CMPSWP_U32 },
288 { "cob_cmpswp_u40", COB_CMPSWP_U40 },
289 { "cob_cmpswp_u48", COB_CMPSWP_U48 },
290 { "cob_cmpswp_u56", COB_CMPSWP_U56 },
291 { "cob_cmpswp_u64", COB_CMPSWP_U64 },
292 { "cob_cmp_s8", COB_CMP_S8 },
293 { "cob_cmpswp_s16", COB_CMPSWP_S16 },
294 { "cob_cmpswp_s24", COB_CMPSWP_S24 },
295 { "cob_cmpswp_s32", COB_CMPSWP_S32 },
296 { "cob_cmpswp_s40", COB_CMPSWP_S40 },
297 { "cob_cmpswp_s48", COB_CMPSWP_S48 },
298 { "cob_cmpswp_s56", COB_CMPSWP_S56 },
299 { "cob_cmpswp_s64", COB_CMPSWP_S64 }
300 };
301
302 static const struct optim_table bin_add_funcs[] = {
303 { "cob_add_u8", COB_ADD_U8 },
304 { "cob_add_u16", COB_ADD_U16 },
305 { "cob_add_u24", COB_ADD_U24 },
306 { "cob_add_u32", COB_ADD_U32 },
307 { "cob_add_u40", COB_ADD_U40 },
308 { "cob_add_u48", COB_ADD_U48 },
309 { "cob_add_u56", COB_ADD_U56 },
310 { "cob_add_u64", COB_ADD_U64 },
311 { "cob_add_s8", COB_ADD_S8 },
312 { "cob_add_s16", COB_ADD_S16 },
313 { "cob_add_s24", COB_ADD_S24 },
314 { "cob_add_s32", COB_ADD_S32 },
315 { "cob_add_s40", COB_ADD_S40 },
316 { "cob_add_s48", COB_ADD_S48 },
317 { "cob_add_s56", COB_ADD_S56 },
318 { "cob_add_s64", COB_ADD_S64 },
319 { "cob_add_u8", COB_ADD_U8 },
320 { "cob_addswp_u16", COB_ADDSWP_U16 },
321 { "cob_addswp_u24", COB_ADDSWP_U24 },
322 { "cob_addswp_u32", COB_ADDSWP_U32 },
323 { "cob_addswp_u40", COB_ADDSWP_U40 },
324 { "cob_addswp_u48", COB_ADDSWP_U48 },
325 { "cob_addswp_u56", COB_ADDSWP_U56 },
326 { "cob_addswp_u64", COB_ADDSWP_U64 },
327 { "cob_add_s8", COB_ADD_S8 },
328 { "cob_addswp_s16", COB_ADDSWP_S16 },
329 { "cob_addswp_s24", COB_ADDSWP_S24 },
330 { "cob_addswp_s32", COB_ADDSWP_S32 },
331 { "cob_addswp_s40", COB_ADDSWP_S40 },
332 { "cob_addswp_s48", COB_ADDSWP_S48 },
333 { "cob_addswp_s56", COB_ADDSWP_S56 },
334 { "cob_addswp_s64", COB_ADDSWP_S64 }
335 };
336
337 static const struct optim_table bin_sub_funcs[] = {
338 { "cob_sub_u8", COB_SUB_U8 },
339 { "cob_sub_u16", COB_SUB_U16 },
340 { "cob_sub_u24", COB_SUB_U24 },
341 { "cob_sub_u32", COB_SUB_U32 },
342 { "cob_sub_u40", COB_SUB_U40 },
343 { "cob_sub_u48", COB_SUB_U48 },
344 { "cob_sub_u56", COB_SUB_U56 },
345 { "cob_sub_u64", COB_SUB_U64 },
346 { "cob_sub_s8", COB_SUB_S8 },
347 { "cob_sub_s16", COB_SUB_S16 },
348 { "cob_sub_s24", COB_SUB_S24 },
349 { "cob_sub_s32", COB_SUB_S32 },
350 { "cob_sub_s40", COB_SUB_S40 },
351 { "cob_sub_s48", COB_SUB_S48 },
352 { "cob_sub_s56", COB_SUB_S56 },
353 { "cob_sub_s64", COB_SUB_S64 },
354 { "cob_sub_u8", COB_SUB_U8 },
355 { "cob_subswp_u16", COB_SUBSWP_U16 },
356 { "cob_subswp_u24", COB_SUBSWP_U24 },
357 { "cob_subswp_u32", COB_SUBSWP_U32 },
358 { "cob_subswp_u40", COB_SUBSWP_U40 },
359 { "cob_subswp_u48", COB_SUBSWP_U48 },
360 { "cob_subswp_u56", COB_SUBSWP_U56 },
361 { "cob_subswp_u64", COB_SUBSWP_U64 },
362 { "cob_sub_s8", COB_SUB_S8 },
363 { "cob_subswp_s16", COB_SUBSWP_S16 },
364 { "cob_subswp_s24", COB_SUBSWP_S24 },
365 { "cob_subswp_s32", COB_SUBSWP_S32 },
366 { "cob_subswp_s40", COB_SUBSWP_S40 },
367 { "cob_subswp_s48", COB_SUBSWP_S48 },
368 { "cob_subswp_s56", COB_SUBSWP_S56 },
369 { "cob_subswp_s64", COB_SUBSWP_S64 }
370 };
371
372 #if defined(COB_NON_ALIGNED) && !defined(_MSC_VER) && defined(COB_ALLOW_UNALIGNED)
373 static const struct optim_table align_bin_compare_funcs[] = {
374 { "cob_cmp_u8", COB_CMP_U8 },
375 { "cob_cmp_align_u16", COB_CMP_ALIGN_U16 },
376 { "cob_cmp_u24", COB_CMP_U24 },
377 { "cob_cmp_align_u32", COB_CMP_ALIGN_U32 },
378 { "cob_cmp_u40", COB_CMP_U40 },
379 { "cob_cmp_u48", COB_CMP_U48 },
380 { "cob_cmp_u56", COB_CMP_U56 },
381 { "cob_cmp_align_u64", COB_CMP_ALIGN_U64 },
382 { "cob_cmp_s8", COB_CMP_S8 },
383 { "cob_cmp_align_s16", COB_CMP_ALIGN_S16 },
384 { "cob_cmp_s24", COB_CMP_S24 },
385 { "cob_cmp_align_s32", COB_CMP_ALIGN_S32 },
386 { "cob_cmp_s40", COB_CMP_S40 },
387 { "cob_cmp_s48", COB_CMP_S48 },
388 { "cob_cmp_s56", COB_CMP_S56 },
389 { "cob_cmp_align_s64", COB_CMP_ALIGN_S64 },
390 { "cob_cmp_u8", COB_CMP_U8 },
391 { "cob_cmpswp_align_u16", COB_CMPSWP_ALIGN_U16 },
392 { "cob_cmpswp_u24", COB_CMPSWP_U24 },
393 { "cob_cmpswp_align_u32", COB_CMPSWP_ALIGN_U32 },
394 { "cob_cmpswp_u40", COB_CMPSWP_U40 },
395 { "cob_cmpswp_u48", COB_CMPSWP_U48 },
396 { "cob_cmpswp_u56", COB_CMPSWP_U56 },
397 { "cob_cmpswp_align_u64", COB_CMPSWP_ALIGN_U64 },
398 { "cob_cmp_s8", COB_CMP_S8 },
399 { "cob_cmpswp_align_s16", COB_CMPSWP_ALIGN_S16 },
400 { "cob_cmpswp_s24", COB_CMPSWP_S24 },
401 { "cob_cmpswp_align_s32", COB_CMPSWP_ALIGN_S32 },
402 { "cob_cmpswp_s40", COB_CMPSWP_S40 },
403 { "cob_cmpswp_s48", COB_CMPSWP_S48 },
404 { "cob_cmpswp_s56", COB_CMPSWP_S56 },
405 { "cob_cmpswp_align_s64", COB_CMPSWP_ALIGN_S64 },
406 };
407
408 static const struct optim_table align_bin_add_funcs[] = {
409 { "cob_add_u8", COB_ADD_U8 },
410 { "cob_add_align_u16", COB_ADD_ALIGN_U16 },
411 { "cob_add_u24", COB_ADD_U24 },
412 { "cob_add_align_u32", COB_ADD_ALIGN_U32 },
413 { "cob_add_u40", COB_ADD_U40 },
414 { "cob_add_u48", COB_ADD_U48 },
415 { "cob_add_u56", COB_ADD_U56 },
416 { "cob_add_align_u64", COB_ADD_ALIGN_U64 },
417 { "cob_add_s8", COB_ADD_S8 },
418 { "cob_add_align_s16", COB_ADD_ALIGN_S16 },
419 { "cob_add_s24", COB_ADD_S24 },
420 { "cob_add_align_s32", COB_ADD_ALIGN_S32 },
421 { "cob_add_s40", COB_ADD_S40 },
422 { "cob_add_s48", COB_ADD_S48 },
423 { "cob_add_s56", COB_ADD_S56 },
424 { "cob_add_align_s64", COB_ADD_ALIGN_S64 },
425 { "cob_add_u8", COB_ADD_U8 },
426 { "cob_addswp_u16", COB_ADDSWP_U16 },
427 { "cob_addswp_u24", COB_ADDSWP_U24 },
428 { "cob_addswp_u32", COB_ADDSWP_U32 },
429 { "cob_addswp_u40", COB_ADDSWP_U40 },
430 { "cob_addswp_u48", COB_ADDSWP_U48 },
431 { "cob_addswp_u56", COB_ADDSWP_U56 },
432 { "cob_addswp_u64", COB_ADDSWP_U64 },
433 { "cob_add_s8", COB_ADD_S8 },
434 { "cob_addswp_s16", COB_ADDSWP_S16 },
435 { "cob_addswp_s24", COB_ADDSWP_S24 },
436 { "cob_addswp_s32", COB_ADDSWP_S32 },
437 { "cob_addswp_s40", COB_ADDSWP_S40 },
438 { "cob_addswp_s48", COB_ADDSWP_S48 },
439 { "cob_addswp_s56", COB_ADDSWP_S56 },
440 { "cob_addswp_s64", COB_ADDSWP_S64 },
441 };
442
443 static const struct optim_table align_bin_sub_funcs[] = {
444 { "cob_sub_u8", COB_SUB_U8 },
445 { "cob_sub_align_u16", COB_SUB_ALIGN_U16 },
446 { "cob_sub_u24", COB_SUB_U24 },
447 { "cob_sub_align_u32", COB_SUB_ALIGN_U32 },
448 { "cob_sub_u40", COB_SUB_U40 },
449 { "cob_sub_u48", COB_SUB_U48 },
450 { "cob_sub_u56", COB_SUB_U56 },
451 { "cob_sub_align_u64", COB_SUB_ALIGN_U64 },
452 { "cob_sub_s8", COB_SUB_S8 },
453 { "cob_sub_align_s16", COB_SUB_ALIGN_S16 },
454 { "cob_sub_s24", COB_SUB_S24 },
455 { "cob_sub_align_s32", COB_SUB_ALIGN_S32 },
456 { "cob_sub_s40", COB_SUB_S40 },
457 { "cob_sub_s48", COB_SUB_S48 },
458 { "cob_sub_s56", COB_SUB_S56 },
459 { "cob_sub_align_s64", COB_SUB_ALIGN_S64 },
460 { "cob_sub_u8", COB_SUB_U8 },
461 { "cob_subswp_u16", COB_SUBSWP_U16 },
462 { "cob_subswp_u24", COB_SUBSWP_U24 },
463 { "cob_subswp_u32", COB_SUBSWP_U32 },
464 { "cob_subswp_u40", COB_SUBSWP_U40 },
465 { "cob_subswp_u48", COB_SUBSWP_U48 },
466 { "cob_subswp_u56", COB_SUBSWP_U56 },
467 { "cob_subswp_u64", COB_SUBSWP_U64 },
468 { "cob_sub_s8", COB_SUB_S8 },
469 { "cob_subswp_s16", COB_SUBSWP_S16 },
470 { "cob_subswp_s24", COB_SUBSWP_S24 },
471 { "cob_subswp_s32", COB_SUBSWP_S32 },
472 { "cob_subswp_s40", COB_SUBSWP_S40 },
473 { "cob_subswp_s48", COB_SUBSWP_S48 },
474 { "cob_subswp_s56", COB_SUBSWP_S56 },
475 { "cob_subswp_s64", COB_SUBSWP_S64 },
476 };
477 #endif
478
479 /* Functions */
480 static void cb_walk_cond (cb_tree x);
481
482 static cb_tree
cb_check_needs_break(cb_tree stmt)483 cb_check_needs_break (cb_tree stmt)
484 {
485 cb_tree l;
486
487 /* Check if last statement is GO TO */
488 for (l = stmt; l; l = CB_CHAIN (l)) {
489 if (!CB_CHAIN(l)) {
490 break;
491 }
492 }
493 if (l && CB_VALUE (l) && CB_STATEMENT_P (CB_VALUE (l))) {
494 l = CB_STATEMENT(CB_VALUE(l))->body;
495 if (l && CB_VALUE (l) && !CB_GOTO_P (CB_VALUE(l))) {
496 /* Append a break */
497 l = cb_build_direct ("break;", 0);
498 return cb_list_add (stmt, l);
499 }
500 }
501 return stmt;
502 }
503
504 static size_t
cb_validate_one(cb_tree x)505 cb_validate_one (cb_tree x)
506 {
507 cb_tree y;
508 struct cb_field *f;
509
510 if (x == cb_error_node) {
511 return 1;
512 }
513 if (!x) {
514 return 0;
515 }
516 if (CB_REFERENCE_P (x)) {
517 y = cb_ref (x);
518 if (y == cb_error_node) {
519 return 1;
520 }
521 if (CB_FIELD_P (y)) {
522 f = CB_FIELD (y);
523 if (f->level == 88) {
524 cb_error_x (x, _("condition-name not allowed here: '%s'"), f->name);
525 return 1;
526 }
527 if (f->flag_invalid) {
528 return 1;
529 }
530 /* validate use of handles depending on the statement */
531 if (f->usage == CB_USAGE_HNDL ||
532 f->usage == CB_USAGE_HNDL_WINDOW ||
533 f->usage == CB_USAGE_HNDL_SUBWINDOW ||
534 f->usage == CB_USAGE_HNDL_FONT ||
535 f->usage == CB_USAGE_HNDL_THREAD ||
536 f->usage == CB_USAGE_HNDL_MENU ||
537 f->usage == CB_USAGE_HNDL_VARIANT ||
538 f->usage == CB_USAGE_HNDL_LM) {
539 /* valid statements: CALL, MOVE, DISPLAY + expressions
540 the only statements reaching this are MOVE and DISPLAY */
541 if (strcmp (current_statement->name, "MOVE") != 0 &&
542 strcmp (current_statement->name, "DISPLAY") != 0 &&
543 strcmp (current_statement->name, "DESTROY") != 0 &&
544 strcmp (current_statement->name, "CLOSE WINDOW") != 0) {
545 cb_error_x (x, _("%s item not allowed here: '%s'"),
546 "HANDLE", f->name);
547 return 1;
548 }
549 }
550 }
551 }
552 return 0;
553 }
554
555 static size_t
cb_validate_list(cb_tree l)556 cb_validate_list (cb_tree l)
557 {
558 for (; l; l = CB_CHAIN (l)) {
559 if (cb_validate_one (CB_VALUE (l))) {
560 return 1;
561 }
562 }
563 return 0;
564 }
565
566 static cb_tree
cb_check_group_name(cb_tree x)567 cb_check_group_name (cb_tree x)
568 {
569 cb_tree y;
570
571 if (x == cb_error_node) {
572 return cb_error_node;
573 }
574
575 if (CB_REFERENCE_P (x)) {
576 y = cb_ref (x);
577 if (y == cb_error_node) {
578 return cb_error_node;
579 }
580 if (CB_FIELD_P (y)
581 && CB_FIELD (y)->children != NULL
582 && CB_REFERENCE (x)->offset == NULL) {
583 return x;
584 }
585 }
586
587 cb_error_x (x, _("'%s' is not a group name"), cb_name (x));
588 return cb_error_node;
589 }
590
591 static cb_tree
cb_check_numeric_name(cb_tree x)592 cb_check_numeric_name (cb_tree x)
593 {
594 #if 0 /* already checked before called */
595 if (x == cb_error_node) {
596 return cb_error_node;
597 }
598 #endif
599
600 if (CB_REFERENCE_P (x)
601 && CB_FIELD_P (cb_ref (x))
602 && CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC) {
603 return x;
604 }
605
606 cb_error_x (x, _("'%s' is not a numeric name"), cb_name (x));
607 return cb_error_node;
608 }
609
610 static cb_tree
cb_check_numeric_edited_name(cb_tree x)611 cb_check_numeric_edited_name (cb_tree x)
612 {
613 #if 0 /* already checked before called */
614 if (x == cb_error_node) {
615 return cb_error_node;
616 }
617 #endif
618
619 if (CB_REFERENCE_P (x)
620 && CB_FIELD_P (cb_ref (x))) {
621 enum cb_category cat = CB_TREE_CATEGORY(x);
622 if (cat == CB_CATEGORY_NUMERIC
623 || cat == CB_CATEGORY_NUMERIC_EDITED
624 || cat == CB_CATEGORY_FLOATING_EDITED) {
625 return x;
626 }
627 }
628
629 cb_error_x (x, _("'%s' is not a numeric or numeric-edited name"), cb_name (x));
630 return cb_error_node;
631 }
632
633 cb_tree
cb_check_sum_field(cb_tree x)634 cb_check_sum_field (cb_tree x)
635 {
636 struct cb_field *f, *sc;
637
638 if (CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC_EDITED) {
639 return x;
640 }
641
642 f = CB_FIELD (cb_ref(x));
643 if (f->report) { /* If part of a REPORT, check if it is a SUM */
644 sc = get_sum_data_field(f->report, f);
645 if (sc) { /* Use the SUM variable instead of the print variable */
646 return cb_build_field_reference (sc, NULL);
647 }
648 }
649 return x;
650 }
651
652 cb_tree
cb_check_numeric_value(cb_tree x)653 cb_check_numeric_value (cb_tree x)
654 {
655 struct cb_field *f, *sc;
656 enum cb_category cat;
657
658 if (cb_validate_one (x)) {
659 return cb_error_node;
660 }
661
662 cat = CB_TREE_CATEGORY (x);
663 if (cat == CB_CATEGORY_NUMERIC) {
664 return x;
665 }
666
667 switch (cat) {
668 case CB_CATEGORY_ALPHABETIC:
669 cb_error_x (x, _("'%s' is Alpha, instead of a numeric value"), cb_name (x));
670 break;
671 case CB_CATEGORY_ALPHANUMERIC_EDITED:
672 cb_error_x (x, _("'%s' is Alpha Edited, instead of a numeric value"), cb_name (x));
673 break;
674 case CB_CATEGORY_NUMERIC_EDITED:
675 case CB_CATEGORY_FLOATING_EDITED:
676 f = CB_FIELD (cb_ref(x));
677 if (f->report) {
678 sc = get_sum_data_field (f->report, f);
679 if (sc) { /* Use the SUM variable instead of the print variable */
680 return cb_build_field_reference (sc, NULL);
681 }
682 }
683 /* Fall-through as we only allow this for RW: SUM */
684 default:
685 cb_error_x (x, _("'%s' is not a numeric value"), cb_name (x));
686 }
687 return cb_error_node;
688 }
689
690 static cb_tree
cb_check_integer_value(cb_tree x)691 cb_check_integer_value (cb_tree x)
692 {
693 struct cb_literal *l;
694 struct cb_field *f;
695 cb_tree y;
696
697 if (x == cb_error_node) {
698 return cb_error_node;
699 }
700
701 if (CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC) {
702 goto invalid;
703 }
704
705 switch (CB_TREE_TAG (x)) {
706 case CB_TAG_CONST:
707 if (x != cb_zero) {
708 goto invalid;
709 }
710 return x;
711 case CB_TAG_LITERAL:
712 l = CB_LITERAL (x);
713 if (l->sign < 0 || l->scale > 0) {
714 goto invliteral;
715 }
716 return x;
717 case CB_TAG_REFERENCE:
718 y = cb_ref (x);
719 if (y == cb_error_node) {
720 return cb_error_node;
721 }
722 f = CB_FIELD (y);
723 if (f->pic->scale > 0) {
724 goto invalid;
725 }
726 return x;
727 case CB_TAG_BINARY_OP:
728 /* TODO: need to check */
729 return x;
730 case CB_TAG_INTRINSIC:
731 /* TODO: need to check */
732 return x;
733 default:
734 invalid:
735 cb_error_x (x, _("'%s' is not an integer value"), cb_name (x));
736 return cb_error_node;
737 }
738 invliteral:
739 cb_error_x (x, _("positive numeric integer is required here"));
740 return cb_error_node;
741 }
742
743 static void
cb_check_data_incompat(cb_tree x)744 cb_check_data_incompat (cb_tree x)
745 {
746 struct cb_field *f;
747
748 /* TO-DO: Check for EC-DATA-INCOMPATIBLE checking */
749
750 if (!x || x == cb_error_node) {
751 return;
752 }
753 if (!CB_REF_OR_FIELD_P (x) ||
754 CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC) {
755 return;
756 }
757 f = CB_FIELD_PTR (x);
758 if (cb_flag_correct_numeric && f->usage == CB_USAGE_DISPLAY) {
759 cb_emit (CB_BUILD_FUNCALL_1 ("cob_correct_numeric", x));
760 }
761 if (CB_EXCEPTION_ENABLE (COB_EC_DATA_INCOMPATIBLE)) {
762 if (f->usage == CB_USAGE_DISPLAY ||
763 f->usage == CB_USAGE_PACKED ||
764 f->usage == CB_USAGE_COMP_6) {
765 cb_emit (CB_BUILD_FUNCALL_2 ("cob_check_numeric",
766 x,
767 CB_BUILD_STRING0 (f->name)));
768 }
769 }
770 }
771
772 static void
cb_check_lit_subs(struct cb_reference * r,const int numsubs,const int numindex)773 cb_check_lit_subs (struct cb_reference *r, const int numsubs,
774 const int numindex)
775 {
776 cb_tree l;
777 cb_tree v;
778 struct cb_literal *lt;
779 int size;
780
781 /* Check for DPC and non-standard separator usage */
782 if (!cb_relaxed_syntax_checks ||
783 current_program->decimal_point != ',') {
784 return;
785 }
786 if (numsubs > numindex) {
787 return;
788 }
789
790 for (l = r->subs; l; l = CB_CHAIN (l)) {
791 v = CB_VALUE (l);
792 if (v == cb_error_node) {
793 continue;
794 }
795 if (!CB_LITERAL_P (v)) {
796 continue;
797 }
798 lt = CB_LITERAL (v);
799 if (!lt->scale) {
800 continue;
801 }
802 if (lt->scale == (int)lt->size) {
803 lt->scale = 0;
804 continue;
805 }
806 size = lt->size - lt->scale;
807 v = cb_build_numsize_literal (<->data[size],
808 (size_t)lt->scale, lt->sign);
809 CB_VALUE (l) = v;
810 v = cb_build_numsize_literal (lt->data, (size_t)size, 0);
811 CB_CHAIN (l) = CB_BUILD_CHAIN (v, CB_CHAIN (l));
812 }
813 return;
814 }
815
816 static int
usage_is_thread_handle(cb_tree x)817 usage_is_thread_handle (cb_tree x)
818 {
819 struct cb_field *f;
820 f = CB_FIELD_PTR (x);
821
822 if (f->usage == CB_USAGE_HNDL ||
823 f->usage == CB_USAGE_HNDL_THREAD) {
824 return 1;
825 }
826 return 0;
827 }
828
829 static int
usage_is_window_handle(cb_tree x)830 usage_is_window_handle (cb_tree x)
831 {
832 struct cb_field *f;
833 f = CB_FIELD_PTR (x);
834
835 if (f->usage == CB_USAGE_HNDL ||
836 f->usage == CB_USAGE_HNDL_WINDOW ||
837 f->usage == CB_USAGE_HNDL_SUBWINDOW) {
838 return 1;
839 }
840 if (f->usage == CB_USAGE_DISPLAY &&
841 f->pic->category == CB_CATEGORY_ALPHANUMERIC &&
842 f->size == 10){
843 return 1;
844 }
845 return 0;
846 }
847
848 /* List system routines */
849
850 void
cb_list_system_routines(void)851 cb_list_system_routines (void)
852 {
853 const struct system_table *psyst;
854
855 putchar ('\n');
856
857 putchar ('\n');
858 printf ("%-32s%s\n", _("System routine"), _("Parameters"));
859 putchar ('\n');
860
861 for (psyst = system_tab; psyst->syst_name; psyst++) {
862 if (strlen (psyst->syst_name) != 1) {
863 printf ("%-32s", psyst->syst_name);
864 } else {
865 printf ("X\"%2X\"%-27s", (unsigned char)psyst->syst_name[0], "");
866 }
867 if (psyst->syst_params_min != psyst->syst_params_max) {
868 printf ("%d - %d", psyst->syst_params_min, psyst->syst_params_max);
869 } else {
870 printf ("%d", psyst->syst_params_min);
871 }
872 putchar ('\n');
873 }
874 }
875
876 /* Check if tree is an INDEX */
877 size_t
cb_check_index_or_handle_p(cb_tree x)878 cb_check_index_or_handle_p (cb_tree x)
879 {
880 struct cb_field *f;
881
882 if (!CB_REF_OR_FIELD_P (x)) {
883 return 0;
884 }
885 f = CB_FIELD_PTR (x);
886 if (f->children) {
887 return 0;
888 }
889 if (f->usage == CB_USAGE_INDEX ||
890 f->usage == CB_USAGE_HNDL ||
891 f->usage == CB_USAGE_HNDL_WINDOW ||
892 f->usage == CB_USAGE_HNDL_SUBWINDOW ||
893 f->usage == CB_USAGE_HNDL_FONT ||
894 f->usage == CB_USAGE_HNDL_THREAD ||
895 f->usage == CB_USAGE_HNDL_MENU ||
896 f->usage == CB_USAGE_HNDL_VARIANT ||
897 f->usage == CB_USAGE_HNDL_LM) {
898 return 1;
899 }
900 return 0;
901 }
902
903 /* Check if a field reference requires debugging */
904
905 void
cb_check_field_debug(cb_tree fld)906 cb_check_field_debug (cb_tree fld)
907 {
908 cb_tree l;
909 cb_tree x;
910 cb_tree z;
911 size_t size;
912 size_t found;
913 char buff[COB_MINI_BUFF];
914
915 /* Basic reference check */
916 if (CB_WORD_COUNT (fld) > 0) {
917 if (!CB_WORD_ITEMS (fld)) {
918 return;
919 }
920 z = CB_VALUE(CB_WORD_ITEMS (fld));
921 if (!CB_FIELD_P (z)) {
922 return;
923 }
924 x = cb_ref (fld);
925 if (x == cb_error_node) {
926 return;
927 }
928 } else {
929 return;
930 }
931
932 found = 0;
933 /* Check if reference is being debugged */
934 for (l = current_program->debug_list; l; l = CB_CHAIN (l)) {
935 if (!CB_PURPOSE (l)) {
936 continue;
937 }
938 if (x == CB_PURPOSE (l)) {
939 if (CB_REFERENCE (fld)->flag_target ||
940 CB_REFERENCE (CB_VALUE (l))->flag_all_debug) {
941 found = 1;
942 }
943 break;
944 }
945 }
946 if (!found) {
947 return;
948 }
949
950 found = 0;
951 /* Found it - check if it is already in the statement list */
952 for (l = current_statement->debug_nodups; l; l = CB_CHAIN (l)) {
953 if (CB_VALUE (l) == x) {
954 found = 1;
955 break;
956 }
957 }
958 if (found) {
959 return;
960 }
961
962 /* Set up debug info */
963 strncpy (buff, CB_FIELD(x)->name, COB_MAX_WORDLEN);
964 buff[COB_MAX_WORDLEN] = 0;
965 l = CB_REFERENCE (fld)->chain;
966 if (l) {
967 size = strlen (buff);
968 for (; l; l = CB_REFERENCE (l)->chain) {
969 z = cb_ref (l);
970 if (z != cb_error_node) {
971 size += strlen (CB_FIELD (z)->name);
972 size += 4;
973 if (size >= sizeof(buff)) {
974 break;
975 }
976 strcat (buff, " OF ");
977 strcat (buff, CB_FIELD (z)->name);
978 }
979 }
980 }
981 current_statement->debug_nodups =
982 cb_list_add (current_statement->debug_nodups, x);
983 current_statement->debug_check =
984 cb_list_add (current_statement->debug_check,
985 cb_build_debug (cb_debug_name, buff, NULL));
986 current_statement->debug_check =
987 cb_list_add (current_statement->debug_check,
988 cb_build_debug (cb_debug_contents, NULL, fld));
989 found = 0;
990 CB_REFERENCE (fld)->subs = cb_list_reverse (CB_REFERENCE (fld)->subs);
991 l = CB_REFERENCE (fld)->subs;
992 for (; l && found < 3; l = CB_CHAIN (l), ++found) {
993 switch (found) {
994 case 0:
995 current_statement->debug_check =
996 cb_list_add (current_statement->debug_check,
997 cb_build_move (CB_VALUE (l),
998 cb_debug_sub_1));
999 break;
1000 case 1:
1001 current_statement->debug_check =
1002 cb_list_add (current_statement->debug_check,
1003 cb_build_move (CB_VALUE (l),
1004 cb_debug_sub_2));
1005 break;
1006 case 2:
1007 current_statement->debug_check =
1008 cb_list_add (current_statement->debug_check,
1009 cb_build_move (CB_VALUE (l),
1010 cb_debug_sub_3));
1011 break;
1012 default:
1013 break;
1014 }
1015 }
1016 CB_REFERENCE (fld)->subs = cb_list_reverse (CB_REFERENCE (fld)->subs);
1017
1018 for (; found < 3; ++found) {
1019 switch (found) {
1020 case 0:
1021 current_statement->debug_check =
1022 cb_list_add (current_statement->debug_check,
1023 CB_BUILD_FUNCALL_3 ("memset",
1024 CB_BUILD_CAST_ADDRESS (cb_debug_sub_1),
1025 cb_int (' '),
1026 CB_BUILD_CAST_LENGTH (cb_debug_sub_1)));
1027 break;
1028 case 1:
1029 current_statement->debug_check =
1030 cb_list_add (current_statement->debug_check,
1031 CB_BUILD_FUNCALL_3 ("memset",
1032 CB_BUILD_CAST_ADDRESS (cb_debug_sub_2),
1033 cb_int (' '),
1034 CB_BUILD_CAST_LENGTH (cb_debug_sub_2)));
1035 break;
1036 case 2:
1037 current_statement->debug_check =
1038 cb_list_add (current_statement->debug_check,
1039 CB_BUILD_FUNCALL_3 ("memset",
1040 CB_BUILD_CAST_ADDRESS (cb_debug_sub_3),
1041 cb_int (' '),
1042 CB_BUILD_CAST_LENGTH (cb_debug_sub_3)));
1043 break;
1044 default:
1045 break;
1046 }
1047 }
1048
1049 current_statement->debug_check =
1050 cb_list_add (current_statement->debug_check,
1051 cb_build_debug_call (CB_FIELD(x)->debug_section));
1052 }
1053
1054 /* Program registers */
1055
1056
1057 /* RETURN-CODE */
1058 static void
cb_build_register_return_code(const char * name,const char * definition)1059 cb_build_register_return_code (const char *name, const char *definition)
1060 {
1061 cb_tree field;
1062
1063 if (!definition) {
1064 definition = cb_get_register_definition (name);
1065 if (!definition) {
1066 return;
1067 }
1068 }
1069
1070 /* take care of (likely) GLOBAL */
1071 #if 0 /* more to adjust in other places */
1072 if (current_program->nested_level && strstr (definition, "GLOBAL")) {
1073 #else
1074 if (current_program->nested_level) {
1075 #endif
1076 return;
1077 }
1078
1079 field = cb_build_index (cb_build_reference (name), cb_zero, 0, NULL);
1080 CB_FIELD_PTR (field)->index_type = CB_STATIC_INT_INDEX;
1081 CB_FIELD_PTR (field)->flag_internal_register = 1;
1082 CB_FIELD_PTR (field)->flag_real_binary = 1;
1083 current_program->cb_return_code = field;
1084 }
1085
1086 /* SORT-RETURN */
1087 static void
1088 cb_build_register_sort_return (const char *name, const char *definition)
1089 {
1090 cb_tree field;
1091
1092 if (!definition) {
1093 definition = cb_get_register_definition (name);
1094 if (!definition) {
1095 return;
1096 }
1097 }
1098
1099 #if 0 /* more to adjust in other places */
1100 /* take care of (unlikely) GLOBAL */
1101 if (current_program->nested_level && strstr (definition, "GLOBAL")) {
1102 return;
1103 }
1104 #endif
1105
1106 field = cb_build_index (cb_build_reference (name), cb_zero, 0, NULL);
1107 CB_FIELD_PTR (field)->flag_no_init = 1;
1108 CB_FIELD_PTR (field)->flag_internal_register = 1;
1109 CB_FIELD_PTR (field)->flag_real_binary = 1;
1110 current_program->cb_sort_return = field;
1111 }
1112
1113 /* NUMBER-OF-CALL-PARAMETERS (OpenCOBOL/GnuCOBOL extension 1.0+) */
1114 static void
1115 cb_build_register_number_parameters (const char *name, const char *definition)
1116 {
1117 cb_tree field;
1118
1119 if (!definition) {
1120 definition = cb_get_register_definition (name);
1121 if (!definition) {
1122 return;
1123 }
1124 }
1125
1126 field = cb_build_index (cb_build_reference (name), cb_zero, 0, NULL);
1127 CB_FIELD_PTR (field)->flag_no_init = 1;
1128 CB_FIELD_PTR (field)->flag_local = 1;
1129 CB_FIELD_PTR (field)->flag_internal_register = 1;
1130 CB_FIELD_PTR (field)->index_type = CB_INT_INDEX;
1131 CB_FIELD_PTR (field)->flag_real_binary = 1;
1132 current_program->cb_call_params = field;
1133 }
1134
1135 static void cb_build_constant_register (cb_tree name, cb_tree value)
1136 {
1137 cb_tree constant = cb_build_constant (name, value);
1138 CB_FIELD (constant)->flag_internal_register = 1;
1139 }
1140
1141 /* WHEN-COMPILED */
1142 static void
1143 cb_build_register_when_compiled (const char *name, const char *definition)
1144 {
1145 char buff[32]; /* 32: make the compiler happy as "unsigned short" *could*
1146 have more digits than we "assume" */
1147 size_t lit_size;
1148
1149 if (!definition) {
1150 definition = cb_get_register_definition (name);
1151 if (!definition) {
1152 return;
1153 }
1154 }
1155
1156 /* FIXME: the actual content is different for at least OSVS,
1157 as this uses "hh.mm.ssMMM DD, YYYY", we should assume this
1158 if the register's definition contains X(20)! */
1159 #if 0
1160 if (doesn_t_contain_X_20(definition)) {
1161 #endif
1162 snprintf (buff, sizeof (buff), "%2.2d/%2.2d/%2.2d%2.2d.%2.2d.%2.2d",
1163 (cob_u16_t) current_compile_time.day_of_month,
1164 (cob_u16_t) current_compile_time.month,
1165 (cob_u16_t) current_compile_time.year % 100,
1166 (cob_u16_t) current_compile_time.hour,
1167 (cob_u16_t) current_compile_time.minute,
1168 (cob_u16_t) current_compile_time.second);
1169 lit_size = 16;
1170 #if 0
1171 } else {
1172 snprintf (buff, sizeof (buff) + 1, "%2.2d\.%2.2d\.%2.2d%s %2.2d, %4.4d",
1173 (cob_u16_t) current_compile_time.hour,
1174 (cob_u16_t) current_compile_time.minute,
1175 (cob_u16_t) current_compile_time.second,
1176 (cob_u16_t) current_compile_time.month,
1177 (cob_u16_t) current_compile_time.day_of_month,
1178 (cob_u16_t) current_compile_time.year);
1179 lit_size = 20;
1180 }
1181 #endif
1182 cb_build_constant_register (cb_build_reference (name),
1183 cb_build_alphanumeric_literal (buff, lit_size));
1184 }
1185
1186 /* General register creation; used for TALLY, LIN, COL */
1187 /* TODO: complete change to generic function */
1188 int
1189 cb_build_generic_register (const char *name, const char *external_definition)
1190 {
1191 cb_tree field_tree;
1192 char definition[COB_MINI_BUFF];
1193 char *p, *r;
1194 struct cb_field *field;
1195 enum cb_usage usage;
1196 struct cb_picture *picture;
1197
1198 if (!external_definition) {
1199 external_definition = cb_get_register_definition (name);
1200 if (!external_definition) {
1201 return 1;
1202 }
1203 }
1204
1205 strncpy (definition, external_definition, COB_MINI_MAX);
1206 definition[COB_MINI_MAX] = 0;
1207
1208 /* check for GLOBAL, leave if we don't need to define it again (nested program)*/
1209 p = strstr (definition, "GLOBAL");
1210 if (p) {
1211 if (current_program && current_program->nested_level) {
1212 return 0;
1213 }
1214 memset (p, ' ', 6); /* remove from local copy */
1215 }
1216
1217 /* actual field generation */
1218 field_tree = cb_build_field (cb_build_reference (name));
1219 field = CB_FIELD_PTR (field_tree);
1220 field->flag_is_global = (p != NULL); /* any GLOBAL found ? */
1221
1222 /* handle USAGE */
1223 usage = CB_USAGE_DISPLAY;
1224 p = strstr (definition, "USAGE ");
1225 if (p) {
1226 memset (p, ' ', 5);
1227 p += 6;
1228 while (*p == ' ') p++;
1229
1230 if (strncmp (p, "DISPLAY", (size_t)7) == 0) {
1231 memset (p, ' ', 7);
1232 } else {
1233 char temp[COB_MINI_BUFF];
1234 r = p;
1235 while (*r != 0 && *r != ' ') r++;
1236 memcpy (temp, p, r - p);
1237 temp [r - p] = 0;
1238 memset (p, ' ', r - p);
1239 COB_UNUSED (temp); /* FIXME: parse actual USAGE from temp */
1240 usage = CB_USAGE_BINARY;
1241 }
1242 }
1243 field->usage = usage;
1244
1245 /* handle PICTURE */
1246 p = strstr (definition, "PIC ");
1247 if (p) {
1248 memset (p, ' ', 3);
1249 p += 4;
1250 } else {
1251 p = strstr (definition, "PICTURE ");
1252 if (p) {
1253 memset (p, ' ', 7);
1254 p += 8;
1255 }
1256 }
1257 if (p) {
1258 char temp[COB_MINI_BUFF];
1259 while (*p == ' ') p++;
1260 r = p;
1261 while (*r != 0 && *r != ' ') r++;
1262 memcpy (temp, p, r - p);
1263 temp [r - p] = 0;
1264 memset (p, ' ', r - p);
1265 picture = CB_PICTURE (cb_build_picture (temp));
1266 } else {
1267 picture = NULL;
1268 }
1269
1270 field->pic = picture;
1271
1272 /* handle VALUE */
1273 p = strstr (definition, "VALUE ");
1274 if (p) {
1275 memset (p, ' ', 5);
1276 p += 6;
1277 } else {
1278 p = strstr (definition, "VALUES ");
1279 if (p) {
1280 memset (p, ' ', 6);
1281 p += 7;
1282 }
1283 }
1284 if (p) {
1285 COB_UNUSED (p); /* FIXME: parse actual VALUE */
1286 field->values = CB_LIST_INIT (cb_zero);
1287 }
1288 field->flag_internal_register = 1;
1289
1290 /* TODO: check that the local definition is completely parsed -> spaces */
1291
1292 cb_validate_field (field);
1293
1294 field->flag_no_init = 1;
1295 if (current_program) {
1296 CB_FIELD_ADD (current_program->working_storage, field);
1297 } else if (field->flag_is_global) {
1298 CB_FIELD_ADD (external_defined_fields_global, field);
1299 } else {
1300 CB_FIELD_ADD (external_defined_fields_ws, field);
1301 }
1302
1303 return 0;
1304 }
1305
1306 static void
1307 cb_build_register_xml_code (const char *name, const char *definition)
1308 {
1309 cb_tree tfield;
1310 struct cb_field *field;
1311
1312 if (!definition) {
1313 definition = cb_get_register_definition (name);
1314 if (!definition) {
1315 return;
1316 }
1317 }
1318
1319 /* take care of GLOBAL */
1320 if (current_program->nested_level) {
1321 return;
1322 }
1323
1324 tfield = cb_build_field (cb_build_reference (name));
1325 field = CB_FIELD (tfield);
1326 field->usage = CB_USAGE_BINARY;
1327 field->pic = CB_PICTURE (cb_build_picture ("S9(9)"));
1328 cb_validate_field (field);
1329 field->values = CB_LIST_INIT (cb_zero);
1330 field->flag_no_init = 1;
1331 field->flag_is_global = 1;
1332 field->flag_internal_register = 1;
1333 current_program->xml_code = tfield;
1334 }
1335
1336 /* TO-DO: Duplication! */
1337 static void
1338 cb_build_register_json_code (const char *name, const char *definition)
1339 {
1340 cb_tree tfield;
1341 struct cb_field *field;
1342
1343 if (!definition) {
1344 definition = cb_get_register_definition (name);
1345 if (!definition) {
1346 return;
1347 }
1348 }
1349
1350 /* take care of GLOBAL */
1351 if (current_program->nested_level) {
1352 return;
1353 }
1354
1355 tfield = cb_build_field (cb_build_reference (name));
1356 field = CB_FIELD (tfield);
1357 field->usage = CB_USAGE_BINARY;
1358 field->pic = CB_PICTURE (cb_build_picture ("S9(9)"));
1359 cb_validate_field (field);
1360 field->values = CB_LIST_INIT (cb_zero);
1361 field->flag_no_init = 1;
1362 field->flag_is_global = 1;
1363 field->flag_internal_register = 1;
1364 current_program->json_code = tfield;
1365 }
1366
1367
1368 /* build a concrete register */
1369 static void
1370 cb_build_single_register (const char *name, const char *definition)
1371 {
1372 /* TODO: parse definition here or in sub-functions */
1373
1374 /* registers that are currently created elsewhere
1375 TODO: move them here */
1376 /* FIXME: LENGTH OF (must have different results depending on compiler configuration) */
1377 if (!strcasecmp (name, "ADDRESS OF")
1378 || !strcasecmp (name, "LENGTH OF")
1379 || !strcasecmp (name, "COB-CRT-STATUS")
1380 || !strcasecmp (name, "DEBUG-ITEM")) {
1381 return;
1382 }
1383
1384 /* registers that need a special handling / internal registration */
1385 if (!strcasecmp (name, "JSON-CODE")) {
1386 cb_build_register_json_code (name, definition);
1387 return;
1388 }
1389 if (!strcasecmp (name, "RETURN-CODE")) {
1390 cb_build_register_return_code (name, definition);
1391 return;
1392 }
1393 if (!strcasecmp (name, "SORT-RETURN")) {
1394 cb_build_register_sort_return (name, definition);
1395 return;
1396 }
1397 if (!strcasecmp (name, "NUMBER-OF-CALL-PARAMETERS")) {
1398 cb_build_register_number_parameters (name, definition);
1399 return;
1400 }
1401 if (!strcasecmp (name, "WHEN-COMPILED")) {
1402 cb_build_register_when_compiled (name, definition);
1403 return;
1404 }
1405 if (!strcasecmp (name, "XML-CODE")) {
1406 cb_build_register_xml_code (name, definition);
1407 return;
1408 }
1409
1410 /* "normal" registers */
1411 if (!strcasecmp (name, "TALLY")
1412 || !strcasecmp (name, "LIN")
1413 || !strcasecmp (name, "COL")) {
1414 cb_build_generic_register (name, definition);
1415 return;
1416 }
1417
1418 /* LCOV_EXCL_START */
1419 /* This should never happen (and therefore doesn't get a translation) */
1420 cb_error ("unexpected register %s, defined as \"%s\"", name, definition);
1421 COBC_ABORT();
1422 /* LCOV_EXCL_STOP */
1423 }
1424
1425 /* get all active registers and build them */
1426 void
1427 cb_build_registers (void)
1428 {
1429 const char *name, *definition = NULL;
1430
1431 name = cb_register_list_get_first (&definition);
1432 while (name) {
1433 cb_build_single_register (name, definition);
1434 name = cb_register_list_get_next (&definition);
1435 }
1436 }
1437
1438 /* add registers defined externally (configuration/compiler option) */
1439 void
1440 cb_add_external_defined_registers (void)
1441 {
1442 if (external_defined_fields_ws) {
1443 CB_FIELD_ADD (current_program->working_storage, external_defined_fields_ws);
1444 }
1445 if (external_defined_fields_global && !current_program->nested_level) {
1446 CB_FIELD_ADD (current_program->working_storage, external_defined_fields_global);
1447 }
1448 }
1449
1450 /*
1451 TODO: build on first reference (we have the compile time which is the reason
1452 that it was placed here in the first place available fixed in
1453 current_compile_time now).
1454 */
1455 void
1456 cb_set_intr_when_compiled (void)
1457 {
1458 char buff[36]; /* 36: make the compiler happy as "unsigned short" *could*
1459 have more digits than we "assume" */
1460 cob_u16_t offset_minutes;
1461
1462 snprintf (buff, sizeof (buff), "%4.4d%2.2d%2.2d%2.2d%2.2d%2.2d%2.2d",
1463 (cob_u16_t) current_compile_time.year,
1464 (cob_u16_t) current_compile_time.month,
1465 (cob_u16_t) current_compile_time.day_of_month,
1466 (cob_u16_t) current_compile_time.hour,
1467 (cob_u16_t) current_compile_time.minute,
1468 (cob_u16_t) current_compile_time.second,
1469 (cob_u16_t) (current_compile_time.nanosecond / 10000000));
1470 if (current_compile_time.offset_known) {
1471 if (current_compile_time.utc_offset >= 0) {
1472 offset_minutes = current_compile_time.utc_offset % 60;
1473 } else {
1474 offset_minutes = -current_compile_time.utc_offset % 60;
1475 }
1476 snprintf (buff + 16, (size_t)11, "%+2.2d%2.2d", /* 11: see above */
1477 (cob_s16_t) current_compile_time.utc_offset / 60,
1478 offset_minutes);
1479 } else {
1480 snprintf (buff + 16, (size_t)6, "00000");
1481 }
1482 cb_intr_whencomp = cb_build_alphanumeric_literal (buff, (size_t)21);
1483 }
1484
1485 /* check program-id literal and trim, if necessary */
1486 void
1487 cb_trim_program_id (cb_tree id_literal)
1488 {
1489 char *s;
1490 cob_u32_t len;
1491
1492 s = (char *) (CB_LITERAL (id_literal)->data);
1493 if (!strchr (s, ' ')) {
1494 return;
1495 }
1496
1497 len = (cob_u32_t) strlen (s);
1498 if (*s == ' ') {
1499 /* same warning as in libcob/common.c */
1500 cb_warning_x (COBC_WARN_FILLER, id_literal,
1501 _("'%s' literal includes leading spaces which are omitted"), s);
1502 }
1503 if (s[len - 1] == ' ') {
1504 cb_warning_x (cb_warn_additional, id_literal,
1505 _("'%s' literal includes trailing spaces which are omitted"), s);
1506 }
1507 while (*s == ' ') {
1508 memmove (s, s + 1, len--);
1509 }
1510 while (s[len - 1] == ' ' && len > 0) {
1511 len--;
1512 }
1513 s[len] = 0;
1514 CB_LITERAL (id_literal)->size = len;
1515 }
1516
1517 /** encode given name
1518 \param name to encode
1519 \param strip_path specifying if name may include directory which
1520 should be stripped in the encoded version
1521 \return pointer to encoded name
1522 */
1523 char *
1524 cb_encode_program_id (const char *name, const int strip_path, const int fold_case)
1525 {
1526 const unsigned char *s = (const unsigned char *)name;
1527 unsigned char buff[COB_MINI_BUFF];
1528
1529 /* position after last path separator (included for CALL) */
1530 if (strip_path) {
1531 const unsigned char *t;
1532 for (t = s + strlen (name); t > s; t--) {
1533 if (*t == (unsigned char)'/' || *t == (unsigned char)'\\') {
1534 s = t + 1;
1535 break;
1536 }
1537 }
1538 }
1539
1540 /* Encode program name, including case folding */
1541 cob_encode_program_id ((unsigned char *)name, buff, COB_MINI_MAX, fold_case);
1542
1543 return cobc_check_string ((char *)buff);
1544 }
1545
1546 char *
1547 cb_build_program_id (const char *name, const cob_u32_t is_func)
1548 {
1549 /* always convert function names to upper case */
1550 const int folding = is_func ? COB_FOLD_UPPER : cb_fold_call;
1551
1552 /* checking for valid name, the error raised there is enough to stop
1553 the generation, therefore we ignore the result */
1554 (void)cobc_check_valid_name (name, PROGRAM_ID_NAME);
1555
1556 /* Set and encode the PROGRAM-ID */
1557 current_program->orig_program_id = (char *) name;
1558 return cb_encode_program_id (name, 0, folding);
1559 }
1560
1561 cb_tree
1562 cb_define_switch_name (cb_tree name, cb_tree sname, const int flag)
1563 {
1564 cb_tree switch_id;
1565 cb_tree value;
1566
1567 if (!name || name == cb_error_node) {
1568 return NULL;
1569 }
1570 if (!sname || sname == cb_error_node ||
1571 CB_SYSTEM_NAME (sname)->category != CB_SWITCH_NAME) {
1572 cb_error_x (name, _("ON/OFF usage requires a SWITCH name"));
1573 return NULL;
1574 }
1575 switch_id = cb_int (CB_SYSTEM_NAME (sname)->token);
1576 value = CB_BUILD_FUNCALL_1 ("cob_get_switch", switch_id);
1577 if (flag == 0) {
1578 value = CB_BUILD_NEGATION (value);
1579 }
1580 cb_build_constant (name, value);
1581 return value;
1582 }
1583
1584 void
1585 cb_check_word_length (unsigned int length, const char *word)
1586 {
1587 if (unlikely (length > cb_word_length)) {
1588 if (length > COB_MAX_WORDLEN) {
1589 /* Absolute limit */
1590 cb_error (_("word length exceeds maximum of %d characters: '%s'"),
1591 COB_MAX_WORDLEN, word);
1592 } else if (!cb_relaxed_syntax_checks) {
1593 cb_error (_("word length exceeds %d characters: '%s'"),
1594 cb_word_length, word);
1595 } else {
1596 cb_warning (cb_warn_additional, _("word length exceeds %d characters: '%s'"),
1597 cb_word_length, word);
1598 }
1599 }
1600 }
1601
1602 cb_tree
1603 cb_build_section_name (cb_tree name, const int sect_or_para)
1604 {
1605 cb_tree x;
1606 struct cb_word *w;
1607 int nwlength;
1608
1609 if (name == cb_error_node) {
1610 return cb_error_node;
1611 }
1612
1613 /* Check word length
1614 needed here for numeric-only words that bypass the checks
1615 in scanner.l */
1616 w = CB_REFERENCE (name)->word;
1617 for (nwlength = 0; w->name[nwlength] != 0; nwlength++) {
1618 if (!isdigit ((int)w->name[nwlength])) {
1619 nwlength = 0;
1620 break;
1621 }
1622 }
1623 if (nwlength > 0) {
1624 cb_check_word_length(nwlength, w->name);
1625 }
1626
1627 if (CB_WORD_COUNT (name) > 0) {
1628 x = CB_VALUE (CB_WORD_ITEMS (name));
1629 /*
1630 Used as a non-label name or used as a section name.
1631 Duplicate paragraphs are allowed if not referenced;
1632 Checked in typeck.c
1633 */
1634 if (!CB_LABEL_P (x) || sect_or_para == 0 ||
1635 (sect_or_para && CB_LABEL_P (x) &&
1636 CB_LABEL (x)->flag_section)) {
1637 redefinition_error (name);
1638 return cb_error_node;
1639 }
1640 }
1641
1642 return name;
1643 }
1644
1645 static const char *
1646 remove_labels_from_filename (const char *name_ptr)
1647 {
1648 const char *p = NULL;
1649
1650 p = strrchr (name_ptr, '-');
1651 if (p) {
1652 return p + 1;
1653 } else {
1654 return name_ptr;
1655 }
1656 }
1657
1658 /*
1659 Build name for ASSIGN EXTERNAL: convert the word in the ASSIGN clause into
1660 a literal.
1661 */
1662 static cb_tree
1663 build_external_assignment_name (cb_tree name)
1664 {
1665 const char *name_ptr;
1666 const char *orig_ptr;
1667
1668 name_ptr = orig_ptr = CB_NAME (name);
1669
1670 /* Remove (and warn about) labels */
1671 name_ptr = remove_labels_from_filename (name_ptr);
1672 if (name_ptr != orig_ptr) {
1673 cb_warning (cb_warn_additional, _("ASSIGN %s interpreted as '%s'"),
1674 orig_ptr, name_ptr);
1675 }
1676
1677 /* Convert the EXTERNAL name into literal */
1678 return cb_build_alphanumeric_literal (name_ptr, strlen (name_ptr));
1679 }
1680
1681 /* build name for ASSIGN, to be resolved later as we don't have any
1682 field info at this point (postponed to cb_validate_program_data) */
1683 cb_tree
1684 cb_build_assignment_name (struct cb_file *cfile, cb_tree name)
1685 {
1686 if (name == cb_error_node) {
1687 return cb_error_node;
1688 }
1689 /* For special assignment */
1690 if (name == NULL) {
1691 return NULL;
1692 }
1693
1694 if (CB_LITERAL_P (name)) {
1695 return name;
1696 }
1697
1698 if (!CB_REFERENCE_P (name)) {
1699 return cb_error_node;
1700 }
1701
1702 if (cfile->assign_type == CB_ASSIGN_EXT_FILE_NAME_REQUIRED) {
1703 return build_external_assignment_name (name);
1704 } else {
1705 current_program->reference_list =
1706 cb_list_add (current_program->reference_list, name);
1707 return name;
1708 }
1709 }
1710
1711 cb_tree
1712 cb_build_index (cb_tree x, cb_tree values, const unsigned int indexed_by,
1713 struct cb_field *qual)
1714 {
1715 struct cb_field *f;
1716
1717 f = CB_FIELD (cb_build_field (x));
1718 f->usage = CB_USAGE_INDEX;
1719 cb_validate_field (f);
1720 if (values) {
1721 f->values = CB_LIST_INIT (values);
1722 }
1723 if (qual) {
1724 f->index_qual = qual;
1725 }
1726 f->flag_indexed_by = !!indexed_by;
1727 if (f->flag_indexed_by)
1728 f->flag_real_binary = 1;
1729 CB_FIELD_ADD (current_program->working_storage, f);
1730 return x;
1731 }
1732
1733 cb_tree
1734 cb_build_address (cb_tree x)
1735 {
1736 cb_tree v;
1737 struct cb_reference *r;
1738 const char *name;
1739 unsigned int numsubs, refsubs;
1740
1741 if (x == cb_error_node) {
1742 return cb_error_node;
1743 }
1744 if (!CB_REFERENCE_P (x)) {
1745 return CB_BUILD_CAST_ADDRESS (x);
1746 }
1747
1748 r = CB_REFERENCE (x);
1749 name = r->word->name;
1750 v = cb_ref (x);
1751 if (v == cb_error_node) {
1752 return cb_error_node;
1753 }
1754
1755 refsubs = cb_list_length (r->subs);
1756 if (CB_FIELD_P (v)) {
1757 numsubs = CB_FIELD (v)->indexes;
1758 if (refsubs > numsubs) {
1759 goto subserror;
1760 } else if (refsubs < numsubs) {
1761 if (!cb_relaxed_syntax_checks) {
1762 goto subserror;
1763 } else {
1764 cb_warning_x (COBC_WARN_FILLER, x,
1765 _("subscript missing for '%s' - defaulting to 1"),
1766 name);
1767 for (; refsubs < numsubs; ++refsubs) {
1768 CB_ADD_TO_CHAIN (cb_one, r->subs);
1769 }
1770 }
1771 }
1772 } else {
1773 numsubs = 0;
1774 if (r->subs) {
1775 goto subserror;
1776 }
1777 if (r->offset) {
1778 cb_error_x (x, _("'%s' cannot be reference modified"), name);
1779 return cb_error_node;
1780 }
1781 }
1782
1783 return CB_BUILD_CAST_ADDRESS (x);
1784
1785 subserror:
1786 switch (numsubs) {
1787 case 0:
1788 cb_error_x (x, _("'%s' cannot be subscripted"), name);
1789 break;
1790 case 1:
1791 /* FIXME: Change to P_, needs changes to Makevars and tests */
1792 cb_error_x (x, _("'%s' requires one subscript"), name);
1793 break;
1794 default:
1795 cb_error_x (x, _("'%s' requires %d subscripts"),
1796 name, numsubs);
1797 break;
1798 }
1799 return cb_error_node;
1800 }
1801
1802 /* return a reference for a given field combination, needed for calls to CB_FUNC_CALL
1803 as the string would not be allocated during codegen otherwise */
1804 static cb_tree
1805 cb_build_name_reference (struct cb_field *f1, struct cb_field *f2)
1806 {
1807 char full_name[COB_MAX_WORDLEN * 2 + 10];
1808 if (f1 == f2) {
1809 /* TRANSLATORS: This msgid is used when a variable name
1810 or label is referenced in a compiler message. */
1811 sprintf(full_name, _("'%s'"), f1->name);
1812 } else {
1813 sprintf(full_name, _("'%s' (accessed by '%s')"), f1->name, f2->name);
1814 }
1815
1816 return cb_build_reference (full_name);
1817 }
1818
1819 cb_tree
1820 cb_build_identifier (cb_tree x, const int subchk)
1821 {
1822 struct cb_reference *r;
1823 struct cb_field *f;
1824 struct cb_field *p;
1825 const char *name;
1826 cb_tree v;
1827 cb_tree e1;
1828 cb_tree l;
1829 cb_tree sub;
1830 int offset;
1831 int length;
1832 int n;
1833 int numsubs;
1834 int refsubs;
1835 int pseudosize;
1836
1837 if (x == cb_error_node) {
1838 return cb_error_node;
1839 }
1840
1841 r = CB_REFERENCE (x);
1842 name = r->word->name;
1843
1844 /* Resolve reference */
1845 v = cb_ref (x);
1846 if (v == cb_error_node) {
1847 return cb_error_node;
1848 }
1849
1850 /* Check if it is a data name */
1851 if (!CB_FIELD_P (v)) {
1852 if (r->subs) {
1853 cb_error_x (x, _("'%s' cannot be subscripted"), name);
1854 return cb_error_node;
1855 }
1856 if (r->offset) {
1857 cb_error_x (x, _("'%s' cannot be reference modified"), name);
1858 return cb_error_node;
1859 }
1860 return x;
1861 }
1862 f = CB_FIELD (v);
1863
1864 /* BASED check and check for OPTIONAL LINKAGE items */
1865
1866 /* CHECKME: do we need the field founder to decide? LINKAGE and flag_item_based
1867 should be available in 'f' already ... */
1868 if (current_statement && !suppress_data_exceptions &&
1869 (CB_EXCEPTION_ENABLE (COB_EC_DATA_PTR_NULL) ||
1870 CB_EXCEPTION_ENABLE (COB_EC_PROGRAM_ARG_OMITTED))) {
1871 p = cb_field_founder (f);
1872 if (p->redefines) {
1873 p = p->redefines;
1874 }
1875 #if 0
1876 /* note: we can only ignore the check for fields with flag_is_pdiv_opt
1877 when we check for COB_EC_PROGRAM_ARG_MISMATCH in all entry points
1878 and this check is currently completely missing... */
1879 if (CB_EXCEPTION_ENABLE (COB_EC_PROGRAM_ARG_OMITTED)
1880 && p->storage == CB_STORAGE_LINKAGE && p->flag_is_pdiv_parm
1881 && !(p->flag_is_pdiv_opt && CB_EXCEPTION_ENABLE (COB_EC_PROGRAM_ARG_MISMATCH)) {
1882 #else
1883 if (CB_EXCEPTION_ENABLE (COB_EC_PROGRAM_ARG_OMITTED)
1884 && p->storage == CB_STORAGE_LINKAGE && p->flag_is_pdiv_parm) {
1885 #endif
1886 current_statement->null_check = CB_BUILD_FUNCALL_3 (
1887 "cob_check_linkage",
1888 cb_build_address (cb_build_field_reference (p, NULL)),
1889 CB_BUILD_STRING0 (
1890 CB_REFERENCE(cb_build_name_reference (p, f))->word->name),
1891 cb_int1);
1892 } else
1893 if (CB_EXCEPTION_ENABLE (COB_EC_DATA_PTR_NULL)
1894 && !current_statement->flag_no_based) {
1895 if (p->flag_item_based
1896 || (p->storage == CB_STORAGE_LINKAGE &&
1897 !(p->flag_is_pdiv_parm || p->flag_is_returning))) {
1898 current_statement->null_check = CB_BUILD_FUNCALL_2 (
1899 "cob_check_based",
1900 cb_build_address (cb_build_field_reference (p, NULL)),
1901 CB_BUILD_STRING0 (
1902 CB_REFERENCE(cb_build_name_reference (p, f))->word->name));
1903 }
1904 }
1905 }
1906
1907 for (l = r->subs; l; l = CB_CHAIN (l)) {
1908 if (CB_BINARY_OP_P (CB_VALUE (l))) {
1909 /* Set special flag for codegen */
1910 CB_BINARY_OP(CB_VALUE(l))->flag = 1;
1911 }
1912 }
1913
1914 /* Check the number of subscripts */
1915 numsubs = refsubs = cb_list_length (r->subs);
1916 cb_check_lit_subs (r, numsubs, f->indexes);
1917 if (subchk) {
1918 if (!f->indexes) {
1919 cb_error_x (x, _("'%s' has no OCCURS clause"), name);
1920 return cb_error_node;
1921 }
1922 numsubs = f->indexes - 1;
1923 } else {
1924 numsubs = f->indexes;
1925 }
1926 if (likely(!r->flag_all)) {
1927 if (refsubs != numsubs) {
1928 if (refsubs > numsubs) {
1929 goto refsubserr;
1930 } else if (refsubs < numsubs) {
1931 if (!cb_relaxed_syntax_checks) {
1932 goto refsubserr;
1933 } else {
1934 cb_warning_x (COBC_WARN_FILLER, x,
1935 _("subscript missing for '%s' - defaulting to 1"),
1936 name);
1937 for (; refsubs < numsubs; ++refsubs) {
1938 CB_ADD_TO_CHAIN (cb_one, r->subs);
1939 }
1940 }
1941 }
1942 }
1943
1944 /* Run-time check for ODO (including all the fields subordinate items) */
1945 if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT) && f->odo_level != 0) {
1946 for (p = f; p; p = p->children) {
1947 if (p->depending && p->depending != cb_error_node
1948 && !p->flag_unbounded) {
1949 e1 = CB_BUILD_FUNCALL_5 ("cob_check_odo",
1950 cb_build_cast_int (p->depending),
1951 cb_int (p->occurs_min),
1952 cb_int (p->occurs_max),
1953 CB_BUILD_STRING0 (p->name),
1954 CB_BUILD_STRING0 (CB_FIELD_PTR (p->depending)->name));
1955 r->check = cb_list_add (r->check, e1);
1956 }
1957 }
1958 }
1959
1960 /* Subscript check along with setting of table offset */
1961 if (r->subs &&! cb_validate_list (r->subs)) {
1962 l = r->subs;
1963 for (p = f; p && l; p = p->parent) {
1964 if (!p->flag_occurs) {
1965 continue;
1966 }
1967 sub = cb_check_integer_value (CB_VALUE (l));
1968 l = CB_CHAIN (l);
1969 if (sub == cb_error_node) {
1970 continue;
1971 }
1972
1973 /* Compile-time check for all literals */
1974 if (CB_LITERAL_P (sub)) {
1975 n = cb_get_int (sub);
1976 if (n < 1 || (!p->flag_unbounded && n > p->occurs_max)) {
1977 if (cb_relaxed_syntax_checks) {
1978 cb_warning_x (COBC_WARN_FILLER, x,
1979 _("subscript of '%s' out of bounds: %d"),
1980 name, n);
1981 continue; /* *skip runtime check, as MF does */
1982 }
1983 cb_error_x (x, _("subscript of '%s' out of bounds: %d"),
1984 name, n);
1985 }
1986 }
1987
1988 /* Run-time check for all non-literals */
1989 if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_SUBSCRIPT)) {
1990 if (p->depending && p->depending != cb_error_node) {
1991 e1 = CB_BUILD_FUNCALL_4 ("cob_check_subscript",
1992 cb_build_cast_int (sub),
1993 cb_build_cast_int (p->depending),
1994 CB_BUILD_STRING0 (name),
1995 cb_int1);
1996 r->check = cb_list_add (r->check, e1);
1997 } else {
1998 if (!CB_LITERAL_P (sub)) {
1999 e1 = CB_BUILD_FUNCALL_4 ("cob_check_subscript",
2000 cb_build_cast_int (sub),
2001 cb_int (p->occurs_max),
2002 CB_BUILD_STRING0 (name),
2003 cb_int0);
2004 r->check = cb_list_add (r->check, e1);
2005 }
2006 }
2007 }
2008 }
2009 }
2010 }
2011
2012 if (subchk) {
2013 r->subs = cb_list_reverse (r->subs);
2014 r->subs = cb_list_add (r->subs, cb_int1);
2015 r->subs = cb_list_reverse (r->subs);
2016 }
2017
2018 /* Reference modification check */
2019 pseudosize = f->size;
2020 if (f->usage == CB_USAGE_NATIONAL ) {
2021 pseudosize = pseudosize / 2;
2022 }
2023 if (r->offset) {
2024 /* Compile-time check */
2025 if (CB_LITERAL_P (r->offset)) {
2026 offset = cb_get_int (r->offset);
2027 if (f->flag_any_length) {
2028 if (offset < 1) {
2029 cb_error_x (x, _("offset of '%s' out of bounds: %d"), name, offset);
2030 } else if (r->length && CB_LITERAL_P (r->length)) {
2031 length = cb_get_int (r->length);
2032 /* FIXME: needs to be supported for zero length literals */
2033 if (length < 1) {
2034 cb_error_x (x, _("length of '%s' out of bounds: %d"),
2035 name, length);
2036 }
2037 }
2038 } else {
2039 if (offset < 1 || offset > pseudosize) {
2040 cb_error_x (x, _("offset of '%s' out of bounds: %d"), name, offset);
2041 } else if (r->length && CB_LITERAL_P (r->length)) {
2042 length = cb_get_int (r->length);
2043 /* FIXME: needs to be supported for zero length literals */
2044 if (length < 1 || length > pseudosize - offset + 1) {
2045 cb_error_x (x, _("length of '%s' out of bounds: %d"),
2046 name, length);
2047 }
2048 }
2049 }
2050 } else if (r->length && CB_LITERAL_P (r->length)) {
2051 length = cb_get_int (r->length);
2052 /* FIXME: needs to be supported for zero length literals */
2053 if (length < 1 || length > pseudosize) {
2054 cb_error_x (x, _("length of '%s' out of bounds: %d"),
2055 name, length);
2056 }
2057 }
2058
2059 /* Run-time check */
2060 if (CB_EXCEPTION_ENABLE (COB_EC_BOUND_REF_MOD)) {
2061 if (f->flag_any_length || !CB_LITERAL_P (r->offset) ||
2062 (r->length && !CB_LITERAL_P (r->length))) {
2063 /* allow everything but negative/zero */
2064 if (cb_ref_mod_zero_length == 2) {
2065 e1 = CB_BUILD_FUNCALL_3 ("cob_check_ref_mod_minimal",
2066 CB_BUILD_STRING0 (f->name),
2067 cb_build_cast_int (r->offset),
2068 r->length ?
2069 cb_build_cast_int (r->length) :
2070 cb_int1);
2071 } else {
2072 /* check upper + size + lower as requested */
2073 e1 = CB_BUILD_FUNCALL_6 ("cob_check_ref_mod_detailed",
2074 CB_BUILD_STRING0 (f->name),
2075 cb_int1, /* abend */
2076 cb_int (cb_ref_mod_zero_length),
2077 f->flag_any_length ?
2078 CB_BUILD_CAST_LENGTH (v) :
2079 cb_int (pseudosize),
2080 cb_build_cast_int (r->offset),
2081 r->length ?
2082 cb_build_cast_int (r->length) :
2083 cb_int1);
2084 }
2085 r->check = cb_list_add (r->check, e1);
2086 }
2087 }
2088 }
2089
2090 if (f->storage == CB_STORAGE_CONSTANT) {
2091 return CB_VALUE (f->values);
2092 }
2093
2094 return x;
2095
2096 refsubserr:
2097 switch (numsubs) {
2098 case 0:
2099 cb_error_x (x, _("'%s' cannot be subscripted"), name);
2100 break;
2101 case 1:
2102 /* FIXME: Change to P_, needs changes to Makevars and tests */
2103 cb_error_x (x, _("'%s' requires one subscript"), name);
2104 break;
2105 default:
2106 cb_error_x (x, _("'%s' requires %d subscripts"),
2107 name, f->indexes);
2108 break;
2109 }
2110 return cb_error_node;
2111 }
2112
2113 static cb_tree
2114 cb_build_length_1 (cb_tree x)
2115 {
2116 struct cb_field *f;
2117 cb_tree e;
2118 cb_tree size;
2119
2120 f = CB_FIELD (cb_ref (x));
2121
2122 if (cb_field_variable_size (f) == NULL) {
2123 /* Constant size */
2124 return cb_int (cb_field_size (x));
2125 }
2126 /* Variable size */
2127 e = NULL;
2128 for (f = f->children; f; f = f->sister) {
2129 size = cb_build_length_1 (cb_build_field_reference (f, x));
2130 if (f->depending) {
2131 if (!cb_flag_odoslide && f->flag_odo_relative) {
2132 size = cb_build_binary_op (size, '*', cb_int (f->occurs_max));
2133 } else {
2134 size = cb_build_binary_op (size, '*', f->depending);
2135 }
2136 } else if (f->occurs_max > 1) {
2137 size = cb_build_binary_op (size, '*',
2138 cb_int (f->occurs_max));
2139 }
2140 e = e ? cb_build_binary_op (e, '+', size) : size;
2141 }
2142 return e;
2143 }
2144
2145 cb_tree
2146 cb_build_const_length (cb_tree x)
2147 {
2148 struct cb_field *f;
2149 char buff[32];
2150
2151 if (x == cb_error_node) {
2152 return cb_error_node;
2153 }
2154 if (CB_INTEGER_P (x)) {
2155 sprintf (buff, "%d", CB_INTEGER(x)->val);
2156 return cb_build_numeric_literal (0, buff, 0);
2157 }
2158 if (CB_LITERAL_P (x)) {
2159 sprintf (buff, "%d", CB_LITERAL(x)->size);
2160 return cb_build_numsize_literal (buff, strlen(buff), 0);
2161 }
2162 if (CB_REFERENCE_P (x)) {
2163 if (cb_ref (x) == cb_error_node) {
2164 return cb_error_node;
2165 }
2166 if (CB_REFERENCE (x)->offset) {
2167 cb_error (_("reference modification not allowed here"));
2168 return cb_error_node;
2169 }
2170 } else if (!CB_FIELD_P(x)) {
2171 return cb_error_node;
2172 }
2173
2174 f = CB_FIELD (cb_ref (x));
2175 cb_validate_field (f);
2176 if (f->flag_any_length) {
2177 cb_error (_("ANY LENGTH item not allowed here"));
2178 return cb_error_node;
2179 }
2180 if (f->level == 88) {
2181 cb_error (_("88 level item not allowed here"));
2182 return cb_error_node;
2183 }
2184 if (cb_field_variable_size (f)) {
2185 cb_error (_("variable length item not allowed here"));
2186 return cb_error_node;
2187 }
2188 memset (buff, 0, sizeof (buff));
2189 if (f->redefines) {
2190 cb_validate_field (f->redefines);
2191 if (f->rename_thru) {
2192 cb_validate_field (f->rename_thru);
2193 }
2194 cb_validate_field (f);
2195 sprintf (buff, "%d", f->size);
2196 } else {
2197 cb_validate_field (f);
2198 sprintf (buff, "%d", f->memory_size);
2199 }
2200 return cb_build_numeric_literal (0, buff, 0);
2201 }
2202
2203 cb_tree
2204 cb_build_const_from (cb_tree x)
2205 {
2206 struct cb_define_struct *p;
2207
2208 if (x == cb_error_node) {
2209 return cb_error_node;
2210 }
2211 p = ppp_search_lists (CB_NAME(x));
2212 if (p == NULL
2213 || p->deftype == PLEX_DEF_DEL) {
2214 cb_error (_("'%s' has not been DEFINEd"), CB_NAME(x));
2215 return cb_error_node;
2216 }
2217
2218 if (p->deftype == PLEX_DEF_NUM) {
2219 return cb_build_numeric_literal (0, p->value, 0);
2220 } else {
2221 return cb_build_alphanumeric_literal (p->value, (size_t)strlen(p->value));
2222 }
2223 }
2224
2225 /**
2226 * build numeric literal for level 78 VALUE START OF with the offset
2227 * of the given item
2228 *
2229 * Note: we don't return an error node even if an error occurs as this would
2230 * trigger a "needs a VALUE clause" error
2231 */
2232 cb_tree
2233 cb_build_const_start (struct cb_field *f, cb_tree x)
2234 {
2235 struct cb_field *target, *p;
2236 char buff[32];
2237
2238 if (x == cb_error_node) {
2239 return cb_error_node;
2240 }
2241 if (CB_REFERENCE_P (x)) {
2242 if (cb_ref (x) == cb_error_node) {
2243 return cb_error_node;
2244 }
2245 if (CB_REFERENCE (x)->offset) {
2246 cb_error (_("reference modification not allowed here"));
2247 return cb_build_numeric_literal (0, "1", 0);
2248 }
2249 } else {
2250 cb_error (_("only field names allowed here"));
2251 return cb_build_numeric_literal (0, "1", 0);
2252 }
2253
2254 target = CB_FIELD (cb_ref (x));
2255 if (!target) {
2256 return cb_error_node;
2257 }
2258 if (!target->flag_external
2259 && target->storage != CB_STORAGE_FILE
2260 && target->storage != CB_STORAGE_LINKAGE) {
2261 cb_error (_("VALUE of '%s': %s target '%s' is invalid"),
2262 f->name, "START OF", target->name);
2263 cb_error (_("target must be in FILE SECTION or LINKAGE SECTION or have the EXTERNAL clause"));
2264 return cb_build_numeric_literal (0, "1", 0);
2265 }
2266
2267 if (target->flag_any_length) {
2268 cb_error (_("ANY LENGTH item not allowed here"));
2269 return cb_build_numeric_literal (0, "1", 0);
2270 }
2271 if (target->level == 88) {
2272 cb_error (_("88 level item not allowed here"));
2273 return cb_build_numeric_literal (0, "1", 0);
2274 }
2275 if (cb_field_variable_size (target)) {
2276 cb_error (_("variable length item not allowed here"));
2277 return cb_build_numeric_literal (0, "1", 0);
2278 }
2279 for (p = target; p; p = p->parent) {
2280 p->flag_is_verified = 0; /* Force redo compute_size */
2281 p->flag_invalid = 0;
2282 cb_validate_field (p);
2283 if (cb_field_variable_size (p)) {
2284 cb_error (_("variable length item not allowed here"));
2285 return cb_build_numeric_literal (0, "1", 0);
2286 }
2287 }
2288 snprintf (buff, sizeof(buff), "%d", target->offset);
2289 for (p = target; p; p = p->parent) {
2290 p->flag_is_verified = 0; /* Force redo compute_size */
2291 p->flag_invalid = 0;
2292 }
2293 return cb_build_numeric_literal (0, buff, 0);
2294 }
2295
2296 /**
2297 * build numeric literal for level 78 VALUE NEXT with the offset
2298 * at which the NEXT byte of storage occurs after the previous data declaration
2299 *
2300 * Important: this is NOT identical with START OF the next item as SYNC may
2301 * set a different offset for it and when the previous data declaration has
2302 * an OCCURS clause, the value returned by NEXT is the offset at which the next
2303 * byte of storage occurs *after the first element* of the table
2304 *
2305 * Note: we don't return an error node even if an error occurs as this would
2306 * trigger a "needs a VALUE clause" error
2307 */
2308 cb_tree
2309 cb_build_const_next (struct cb_field *f)
2310 {
2311 struct cb_field *p;
2312 char buff[32];
2313 struct cb_field *previous;
2314 int sav_min, sav_max;
2315
2316 previous = cb_get_real_field ();
2317
2318 if (!previous) {
2319 cb_error (_("VALUE of '%s': %s target is invalid"),
2320 f->name, "NEXT");
2321 cb_error (_("no previous data-item found"));
2322 return cb_build_numeric_literal (0, "1", 0);
2323 }
2324
2325 if (previous->storage != CB_STORAGE_FILE
2326 && previous->storage != CB_STORAGE_LINKAGE) {
2327 p = previous;
2328 while (p->parent) {
2329 p = p->parent;
2330 }
2331 if (!p->flag_external) {
2332 cb_error (_("VALUE of '%s': %s target is invalid"), f->name, "NEXT");
2333 cb_error (_("target must be in FILE SECTION or LINKAGE SECTION or have the EXTERNAL clause"));
2334 return cb_build_numeric_literal (0, "1", 0);
2335 }
2336 }
2337
2338 /*
2339 * Compute the size of the last and all its parent fields,
2340 * later fields aren't parsed yet and are therefore not counted
2341 */
2342 if (previous->level != 1) {
2343 sav_min = previous->occurs_min;
2344 sav_max = previous->occurs_max;
2345 previous->occurs_min = previous->occurs_max = 1;
2346 for (p = previous; p; p = p->parent) {
2347 p->flag_is_verified = 0; /* Force compute_size */
2348 p->flag_invalid = 0;
2349 cb_validate_field (p);
2350 if (cb_field_variable_size (p)) {
2351 cb_error (_("variable length item not allowed here"));
2352 p->size = 0;
2353 break;
2354 }
2355 if (!p->parent) {
2356 break;
2357 }
2358 }
2359 previous->occurs_min = sav_min;
2360 previous->occurs_max = sav_max;
2361 } else {
2362 p = previous;
2363 }
2364
2365 snprintf (buff, sizeof (buff), "%d", p->size);
2366
2367 /* Force compute_size for later access */
2368 for (p = previous; p; p = p->parent) {
2369 p->flag_is_verified = 0;
2370 p->flag_invalid = 0;
2371 }
2372
2373 return cb_build_numeric_literal (0, buff, 0);
2374 }
2375
2376 cb_tree
2377 cb_build_length (cb_tree x)
2378 {
2379 struct cb_field *f;
2380 struct cb_literal *l;
2381 cb_tree temp;
2382 char buff[32];
2383
2384 if (x == cb_error_node) {
2385 return cb_error_node;
2386 }
2387 if (CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node) {
2388 return cb_error_node;
2389 }
2390
2391 if (CB_LITERAL_P (x)) {
2392 l = CB_LITERAL (x);
2393 sprintf (buff, "%d", (int)l->size);
2394 return cb_build_numeric_literal (0, buff, 0);
2395 }
2396 if (CB_INTRINSIC_P (x)) {
2397 return cb_build_any_intrinsic (CB_LIST_INIT (x));
2398 }
2399 if (CB_REF_OR_FIELD_P (x)) {
2400 if (CB_REFERENCE_P (x) && CB_REFERENCE (x)->offset) {
2401 return cb_build_any_intrinsic (CB_LIST_INIT (x));
2402 }
2403 f = CB_FIELD_PTR (x);
2404 /* CHECKME: Why do we need this in the first place?
2405 Should be validated already, but isn't at least for some
2406 RENAMES entries! */
2407 if (f->size == 0) {
2408 cb_validate_field (f);
2409 }
2410 if (f->flag_any_length) {
2411 return cb_build_any_intrinsic (CB_LIST_INIT (x));
2412 }
2413 if (cb_field_variable_size (f) == NULL) {
2414 sprintf (buff, "%d", cb_field_size (x));
2415 return cb_build_numeric_literal (0, buff, 0);
2416 }
2417 }
2418 temp = cb_build_index (cb_build_filler (), NULL, 0, NULL);
2419 CB_FIELD (cb_ref (temp))->usage = CB_USAGE_LENGTH;
2420 CB_FIELD (cb_ref (temp))->count++;
2421 cb_emit (cb_build_assign (temp, cb_build_length_1 (x)));
2422 return temp;
2423 }
2424
2425 cb_tree
2426 cb_build_ppointer (cb_tree x)
2427 {
2428 struct cb_field *f;
2429
2430 if (x == cb_error_node ||
2431 (CB_REFERENCE_P (x) && cb_ref (x) == cb_error_node)) {
2432 return cb_error_node;
2433 }
2434
2435 if (CB_REFERENCE_P (x)) {
2436 f = CB_FIELD_PTR (cb_ref(x));
2437 f->count++;
2438 }
2439 return CB_BUILD_CAST_PPOINTER (x);
2440 }
2441
2442 /* Validate program */
2443
2444 static int
2445 get_value (cb_tree x)
2446 {
2447 if (x == cb_space) {
2448 return ' ';
2449 } else if (x == cb_zero) {
2450 return '0';
2451 } else if (x == cb_quote) {
2452 return cb_flag_apostrophe ? '\'' : '"';
2453 } else if (x == cb_norm_low) {
2454 return 0;
2455 } else if (x == cb_norm_high) {
2456 return 255;
2457 } else if (x == cb_null) {
2458 return 0;
2459 } else if (CB_TREE_CLASS (x) == CB_CLASS_NUMERIC) {
2460 return cb_get_int (x) - 1;
2461 }
2462 return CB_LITERAL (x)->data[0];
2463 }
2464
2465 static int
2466 cb_validate_collating (cb_tree collating_sequence)
2467 {
2468 cb_tree x;
2469
2470 if (!collating_sequence) {
2471 return 0;
2472 }
2473
2474 x = cb_ref (collating_sequence);
2475 if (!CB_ALPHABET_NAME_P (x)) {
2476 cb_error_x (collating_sequence, _("'%s' is not an alphabet name"),
2477 cb_name (collating_sequence));
2478 return 1;
2479 }
2480 if (CB_ALPHABET_NAME (x)->alphabet_type != CB_ALPHABET_CUSTOM) {
2481 return 0;
2482 }
2483 if (CB_ALPHABET_NAME (x)->low_val_char) {
2484 cb_low = cb_build_alphanumeric_literal ("\0", (size_t)1);
2485 CB_LITERAL(cb_low)->data[0] = (unsigned char)CB_ALPHABET_NAME (x)->low_val_char;
2486 CB_LITERAL(cb_low)->all = 1;
2487 }
2488 if (CB_ALPHABET_NAME (x)->high_val_char != 255){
2489 cb_high = cb_build_alphanumeric_literal ("\0", (size_t)1);
2490 CB_LITERAL(cb_high)->data[0] = (unsigned char)CB_ALPHABET_NAME (x)->high_val_char;
2491 CB_LITERAL(cb_high)->all = 1;
2492 }
2493 return 0;
2494 }
2495
2496 void
2497 cb_validate_program_environment (struct cb_program *prog)
2498 {
2499 cb_tree x;
2500 cb_tree y;
2501 cb_tree l;
2502 cb_tree ls;
2503 struct cb_alphabet_name *ap;
2504 struct cb_class_name *cp;
2505 unsigned char *data;
2506 size_t dupls;
2507 size_t unvals;
2508 size_t count;
2509 int lower;
2510 int upper;
2511 int size;
2512 int n;
2513 int i;
2514 int pos;
2515 int lastval;
2516 int tableval;
2517 int values[256];
2518 int charvals[256];
2519 int dupvals[256];
2520 char errmsg[256];
2521
2522 /* Check ALPHABET clauses */
2523 /* Complicated by difference between code set and collating sequence */
2524 for (l = prog->alphabet_name_list; l; l = CB_CHAIN (l)) {
2525 ap = CB_ALPHABET_NAME (CB_VALUE (l));
2526
2527 /* Native */
2528 if (ap->alphabet_type == CB_ALPHABET_NATIVE) {
2529 for (n = 0; n < 256; n++) {
2530 ap->values[n] = n;
2531 ap->alphachr[n] = n;
2532 }
2533 continue;
2534 }
2535
2536 /* ASCII */
2537 if (ap->alphabet_type == CB_ALPHABET_ASCII) {
2538 for (n = 0; n < 256; n++) {
2539 #ifdef COB_EBCDIC_MACHINE
2540 ap->values[n] = (int)cob_refer_ascii[n];
2541 ap->alphachr[n] = (int)cob_refer_ascii[n];
2542 #else
2543 ap->values[n] = n;
2544 ap->alphachr[n] = n;
2545 #endif
2546 }
2547 continue;
2548 }
2549
2550 /* EBCDIC */
2551 if (ap->alphabet_type == CB_ALPHABET_EBCDIC) {
2552 for (n = 0; n < 256; n++) {
2553 #ifdef COB_EBCDIC_MACHINE
2554 ap->values[n] = n;
2555 ap->alphachr[n] = n;
2556 #else
2557 ap->values[n] = (int)cob_refer_ebcdic[n];
2558 ap->alphachr[n] = (int)cob_refer_ebcdic[n];
2559 #endif
2560 }
2561 continue;
2562 }
2563
2564 /* Custom alphabet */
2565 dupls = 0;
2566 unvals = 0;
2567 pos = 0;
2568 count = 0;
2569 lastval = 0;
2570 tableval = 0;
2571 for (n = 0; n < 256; n++) {
2572 values[n] = -1;
2573 charvals[n] = -1;
2574 dupvals[n] = -1;
2575 ap->values[n] = -1;
2576 ap->alphachr[n] = -1;
2577 }
2578 ap->low_val_char = 0;
2579 ap->high_val_char = 255;
2580 for (y = ap->custom_list; y; y = CB_CHAIN (y)) {
2581 pos++;
2582 if (count > 255) {
2583 unvals = pos;
2584 break;
2585 }
2586 x = CB_VALUE (y);
2587 if (CB_PAIR_P (x)) {
2588 /* X THRU Y */
2589 lower = get_value (CB_PAIR_X (x));
2590 upper = get_value (CB_PAIR_Y (x));
2591 lastval = upper;
2592 if (!count) {
2593 ap->low_val_char = lower;
2594 }
2595 if (lower < 0 || lower > 255) {
2596 unvals = pos;
2597 continue;
2598 }
2599 if (upper < 0 || upper > 255) {
2600 unvals = pos;
2601 continue;
2602 }
2603 if (lower <= upper) {
2604 for (i = lower; i <= upper; i++) {
2605 if (values[i] != -1) {
2606 dupvals[i] = i;
2607 dupls = 1;
2608 }
2609 values[i] = i;
2610 charvals[i] = i;
2611 ap->alphachr[tableval] = i;
2612 ap->values[i] = tableval++;
2613 count++;
2614 }
2615 } else {
2616 for (i = lower; i >= upper; i--) {
2617 if (values[i] != -1) {
2618 dupvals[i] = i;
2619 dupls = 1;
2620 }
2621 values[i] = i;
2622 charvals[i] = i;
2623 ap->alphachr[tableval] = i;
2624 ap->values[i] = tableval++;
2625 count++;
2626 }
2627 }
2628 } else if (CB_LIST_P (x)) {
2629 /* X ALSO Y ... */
2630 if (!count) {
2631 ap->low_val_char = get_value (CB_VALUE (x));
2632 }
2633 for (ls = x; ls; ls = CB_CHAIN (ls)) {
2634 n = get_value (CB_VALUE (ls));
2635 if (!CB_CHAIN (ls)) {
2636 lastval = n;
2637 }
2638 if (n < 0 || n > 255) {
2639 unvals = pos;
2640 continue;
2641 }
2642 if (values[n] != -1) {
2643 dupvals[n] = n;
2644 dupls = 1;
2645 }
2646 values[n] = n;
2647 ap->values[n] = tableval;
2648 if (ls == x) {
2649 ap->alphachr[tableval] = n;
2650 charvals[n] = n;
2651 }
2652 count++;
2653 }
2654 tableval++;
2655 } else {
2656 /* Literal */
2657 if (CB_NUMERIC_LITERAL_P (x)) {
2658 n = get_value (x);
2659 lastval = n;
2660 if (!count) {
2661 ap->low_val_char = n;
2662 }
2663 if (n < 0 || n > 255) {
2664 unvals = pos;
2665 continue;
2666 }
2667 if (values[n] != -1) {
2668 dupvals[n] = n;
2669 dupls = 1;
2670 }
2671 values[n] = n;
2672 charvals[n] = n;
2673 ap->alphachr[tableval] = n;
2674 ap->values[n] = tableval++;
2675 count++;
2676 } else if (CB_LITERAL_P (x)) {
2677 size = (int)CB_LITERAL (x)->size;
2678 data = CB_LITERAL (x)->data;
2679 if (!count) {
2680 ap->low_val_char = data[0];
2681 }
2682 lastval = data[size - 1];
2683 for (i = 0; i < size; i++) {
2684 n = data[i];
2685 if (values[n] != -1) {
2686 dupvals[n] = n;
2687 dupls = 1;
2688 }
2689 values[n] = n;
2690 charvals[n] = n;
2691 ap->alphachr[tableval] = n;
2692 ap->values[n] = tableval++;
2693 count++;
2694 }
2695 } else {
2696 n = get_value (x);
2697 lastval = n;
2698 if (!count) {
2699 ap->low_val_char = n;
2700 }
2701 if (n < 0 || n > 255) {
2702 unvals = pos;
2703 continue;
2704 }
2705 if (values[n] != -1) {
2706 dupls = 1;
2707 }
2708 values[n] = n;
2709 charvals[n] = n;
2710 ap->alphachr[tableval] = n;
2711 ap->values[n] = tableval++;
2712 count++;
2713 }
2714 }
2715 }
2716 if (dupls || unvals) {
2717 if (dupls) {
2718 i = 0;
2719 for (n = 0; n < 256; n++) {
2720 if (dupvals[n] != -1) {
2721 if (i > 240) {
2722 sprintf(&errmsg[i], ", ...");
2723 i = i + 5;
2724 break;
2725 }
2726 if (i) {
2727 sprintf(&errmsg[i], ", ");
2728 i = i + 2;
2729 }
2730 if (isprint(n)) {
2731 errmsg[i++] = (char)n;
2732 } else {
2733 sprintf(&errmsg[i], "x'%02x'", n);
2734 i = i + 5;
2735 }
2736 };
2737 }
2738 errmsg[i] = 0;
2739 cb_error_x (CB_VALUE(l),
2740 _("duplicate character values in alphabet '%s': %s"),
2741 ap->name, errmsg);
2742 }
2743 if (unvals) {
2744 cb_error_x (CB_VALUE(l),
2745 _("invalid character values in alphabet '%s', starting at position %d"),
2746 ap->name, pos);
2747 }
2748 ap->low_val_char = 0;
2749 ap->high_val_char = 255;
2750 continue;
2751 }
2752 /* Calculate HIGH-VALUE */
2753 /* If all 256 values have been specified, */
2754 /* HIGH-VALUE is the last one */
2755 /* Otherwise if HIGH-VALUE has been specified, find the highest */
2756 /* value that has not been used */
2757 if (count == 256) {
2758 ap->high_val_char = lastval;
2759 } else if (values[255] != -1) {
2760 for (n = 254; n >= 0; n--) {
2761 if (values[n] == -1) {
2762 ap->high_val_char = n;
2763 break;
2764 }
2765 }
2766 }
2767
2768 /* Get rest of code set */
2769 for (n = tableval; n < 256; ++n) {
2770 for (i = 0; i < 256; ++i) {
2771 if (charvals[i] < 0) {
2772 charvals[i] = 0;
2773 ap->alphachr[n] = i;
2774 break;
2775 }
2776 }
2777 }
2778
2779 /* Fill in missing characters */
2780 for (n = 0; n < 256; n++) {
2781 if (ap->values[n] < 0) {
2782 ap->values[n] = tableval++;
2783 }
2784 }
2785 }
2786
2787 /* Reset HIGH/LOW-VALUES */
2788 cb_low = cb_norm_low;
2789 cb_high = cb_norm_high;
2790
2791 /* Check and generate SYMBOLIC clauses */
2792 for (l = prog->symbolic_char_list; l; l = CB_CHAIN (l)) {
2793 if (CB_VALUE (l)) {
2794 y = cb_ref (CB_VALUE (l));
2795 if (y == cb_error_node) {
2796 continue;
2797 }
2798 if (!CB_ALPHABET_NAME_P (y)) {
2799 cb_error_x (y, _("invalid ALPHABET name"));
2800 continue;
2801 }
2802 } else {
2803 y = NULL;
2804 }
2805 cb_build_symbolic_chars (CB_PURPOSE (l), y);
2806 }
2807
2808 /* Check CLASS clauses */
2809 for (l = prog->class_name_list; l; l = CB_CHAIN (l)) {
2810 cp = CB_CLASS_NAME (CB_VALUE (l));
2811 /* LCOV_EXCL_START */
2812 if (cp == NULL) { /* keep the analyzer happy... */
2813 cobc_err_msg ("invalid CLASS detected"); /* not translated as highly unlikely */
2814 COBC_ABORT ();
2815 }
2816 /* LCOV_EXCL_STOP */
2817 dupls = 0;
2818 memset (values, 0, sizeof(values));
2819 for (y = cp->list; y; y = CB_CHAIN (y)) {
2820 x = CB_VALUE (y);
2821 if (CB_PAIR_P (x)) {
2822 /* X THRU Y */
2823 lower = get_value (CB_PAIR_X (x));
2824 upper = get_value (CB_PAIR_Y (x));
2825 for (i = lower; i <= upper; i++) {
2826 if (values[i]) {
2827 dupls = 1;
2828 } else {
2829 values[i] = 1;
2830 }
2831 }
2832 } else {
2833 if (CB_NUMERIC_LITERAL_P (x)) {
2834 n = get_value (x);
2835 if (values[n]) {
2836 dupls = 1;
2837 } else {
2838 values[n] = 1;
2839 }
2840 } else if (CB_LITERAL_P (x)) {
2841 size = (int)CB_LITERAL (x)->size;
2842 data = CB_LITERAL (x)->data;
2843 for (i = 0; i < size; i++) {
2844 n = data[i];
2845 if (values[n]) {
2846 dupls = 1;
2847 } else {
2848 values[n] = 1;
2849 }
2850 }
2851 } else {
2852 n = get_value (x);
2853 if (values[n]) {
2854 dupls = 1;
2855 } else {
2856 values[n] = 1;
2857 }
2858 }
2859 }
2860 }
2861 if (dupls) {
2862 cb_warning_x (cb_warn_additional, CB_VALUE(l),
2863 _("duplicate character values in class '%s'"),
2864 cb_name (CB_VALUE(l)));
2865 }
2866 }
2867
2868 /* Resolve the program collating sequences */
2869 if (cb_validate_collating (prog->collating_sequence)) {
2870 prog->collating_sequence = NULL;
2871 };
2872 if (cb_validate_collating (prog->collating_sequence_n)) {
2873 prog->collating_sequence_n = NULL;
2874 };
2875
2876 /* Resolve the program classification */
2877 if (prog->classification && prog->classification != cb_int1) {
2878 x = cb_ref (prog->classification);
2879 if (!CB_LOCALE_NAME_P (x)) {
2880 cb_error_x (prog->classification,
2881 _("'%s' is not a locale name"),
2882 cb_name (prog->classification));
2883 prog->classification = NULL;
2884 return;
2885 }
2886 }
2887 }
2888
2889 /* default (=minimal) size of DEBUG-CONTENTS */
2890 #ifdef DFLT_DEBUG_CONTENTS_SIZE
2891 #if DFLT_DEBUG_CONTENTS_SIZE < 13
2892 #undef DFLT_DEBUG_CONTENTS_SIZE
2893 #define DFLT_DEBUG_CONTENTS_SIZE 13 /* Lenght of fixed values */
2894 #endif
2895 #else
2896 #define DFLT_DEBUG_CONTENTS_SIZE 30
2897 #endif
2898
2899
2900 void
2901 cb_build_debug_item (void)
2902 {
2903 cb_tree l;
2904 cb_tree x;
2905 cb_tree lvl01_tree;
2906
2907 /* Set up DEBUG-ITEM */
2908 l = cb_build_reference ("DEBUG-ITEM");
2909 lvl01_tree = cb_build_field_tree (NULL, l, NULL, CB_STORAGE_WORKING,
2910 NULL, 1);
2911 CB_FIELD (lvl01_tree)->values = CB_LIST_INIT (cb_space);
2912 cb_debug_item = l;
2913
2914 l = cb_build_reference ("DEBUG-LINE");
2915 x = cb_build_field_tree (NULL, l, CB_FIELD(lvl01_tree),
2916 CB_STORAGE_WORKING, NULL, 3);
2917 CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X(6)"));
2918 cb_validate_field (CB_FIELD (x));
2919 cb_debug_line = l;
2920
2921 l = cb_build_filler ();
2922 x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2923 CB_STORAGE_WORKING, NULL, 3);
2924 CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2925 CB_FIELD (x)->flag_filler = 1;
2926 cb_validate_field (CB_FIELD (x));
2927
2928 l = cb_build_reference ("DEBUG-NAME");
2929 x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2930 CB_STORAGE_WORKING, NULL, 3);
2931 CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X(30)"));
2932 cb_validate_field (CB_FIELD (x));
2933 cb_debug_name = l;
2934
2935 l = cb_build_filler ();
2936 x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2937 CB_STORAGE_WORKING, NULL, 3);
2938 CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2939 CB_FIELD (x)->flag_filler = 1;
2940 cb_validate_field (CB_FIELD (x));
2941
2942 l = cb_build_reference ("DEBUG-SUB-1");
2943 x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2944 CB_STORAGE_WORKING, NULL, 3);
2945 CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
2946 CB_FIELD (x)->flag_sign_leading = 1;
2947 CB_FIELD (x)->flag_sign_separate = 1;
2948 cb_validate_field (CB_FIELD (x));
2949 cb_debug_sub_1 = l;
2950
2951 l = cb_build_filler ();
2952 x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2953 CB_STORAGE_WORKING, NULL, 3);
2954 CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2955 CB_FIELD (x)->flag_filler = 1;
2956 cb_validate_field (CB_FIELD (x));
2957
2958 l = cb_build_reference ("DEBUG-SUB-2");
2959 x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2960 CB_STORAGE_WORKING, NULL, 3);
2961 CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
2962 CB_FIELD (x)->flag_sign_leading = 1;
2963 CB_FIELD (x)->flag_sign_separate = 1;
2964 cb_validate_field (CB_FIELD (x));
2965 cb_debug_sub_2 = l;
2966
2967 l = cb_build_filler ();
2968 x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2969 CB_STORAGE_WORKING, NULL, 3);
2970 CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2971 CB_FIELD (x)->flag_filler = 1;
2972 cb_validate_field (CB_FIELD (x));
2973
2974 l = cb_build_reference ("DEBUG-SUB-3");
2975 x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2976 CB_STORAGE_WORKING, NULL, 3);
2977 CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("S9(4)"));
2978 CB_FIELD (x)->flag_sign_leading = 1;
2979 CB_FIELD (x)->flag_sign_separate = 1;
2980 cb_validate_field (CB_FIELD (x));
2981 cb_debug_sub_3 = l;
2982
2983 l = cb_build_filler ();
2984 x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2985 CB_STORAGE_WORKING, NULL, 3);
2986 CB_FIELD (x)->pic = CB_PICTURE (cb_build_picture ("X"));
2987 CB_FIELD (x)->flag_filler = 1;
2988 cb_validate_field (CB_FIELD (x));
2989
2990 l = cb_build_reference ("DEBUG-CONTENTS");
2991 x = cb_build_field_tree (NULL, l, CB_FIELD(x),
2992 CB_STORAGE_WORKING, NULL, 3);
2993 CB_FIELD (x)->pic = CB_PICTURE (
2994 cb_build_picture ("X(" CB_XSTRINGIFY(DFLT_DEBUG_CONTENTS_SIZE) ")"));
2995 cb_validate_field (CB_FIELD (x));
2996 cb_debug_contents = l;
2997
2998 cb_validate_field (CB_FIELD (lvl01_tree));
2999 CB_FIELD_ADD (current_program->working_storage, CB_FIELD (lvl01_tree));
3000 }
3001
3002 static void
3003 validate_record_depending (cb_tree x)
3004 {
3005 struct cb_field *p;
3006 cb_tree r;
3007
3008 /* get reference (and check if it exists) */
3009 r = cb_ref (x);
3010 if (r == cb_error_node) {
3011 return;
3012 }
3013 #if 0 /* Simon: Why should we use a reference here? */
3014 if (CB_REF_OR_FIELD_P(x)) {
3015 cb_error_x (x, _("invalid RECORD DEPENDING item"));
3016 return;
3017 }
3018 #else
3019 if (!CB_FIELD_P(r)) {
3020 cb_error_x (x, _("RECORD DEPENDING must reference a data-item"));
3021 return;
3022 }
3023 #endif
3024 p = CB_FIELD_PTR (x);
3025 switch (p->storage) {
3026 case CB_STORAGE_WORKING:
3027 case CB_STORAGE_LOCAL:
3028 case CB_STORAGE_LINKAGE:
3029 break;
3030 default:
3031 /* RXWRXW - This breaks old legacy programs; FIXME: use compiler configuration */
3032 {
3033 enum cb_support missing_compiler_config;
3034 if (!cb_relaxed_syntax_checks
3035 || cb_warn_opt_val[cb_warn_additional] == COBC_WARN_AS_ERROR) {
3036 missing_compiler_config = CB_ERROR;
3037 } else if (cb_warn_opt_val[cb_warn_additional] == COBC_WARN_ENABLED) {
3038 missing_compiler_config = CB_WARNING;
3039 } else {
3040 missing_compiler_config = CB_OK;
3041 }
3042 cb_warning_dialect_x (missing_compiler_config, x,
3043 _("RECORD DEPENDING item '%s' should be defined in "
3044 "WORKING-STORAGE, LOCAL-STORAGE or LINKAGE SECTION"), p->name);
3045 }
3046 }
3047 }
3048
3049 static void
3050 validate_relative_key_field (struct cb_file *file)
3051 {
3052 struct cb_field *key_field = CB_FIELD_PTR (file->key);
3053
3054 if (CB_TREE_CATEGORY (key_field) != CB_CATEGORY_NUMERIC) {
3055 cb_error_x (file->key,
3056 _("file %s: RELATIVE KEY %s is not numeric"),
3057 file->name, key_field->name);
3058 }
3059
3060 /* TO-DO: Check if key_field is an integer based on USAGE */
3061 if (key_field->pic != NULL) {
3062 if (key_field->pic->category == CB_CATEGORY_NUMERIC
3063 && key_field->pic->scale != 0) {
3064 cb_error_x (file->key,
3065 _("file %s: RELATIVE KEY %s must be integer"),
3066 file->name, key_field->name);
3067 }
3068 if (key_field->pic->have_sign) {
3069 cb_error_x (file->key,
3070 _("file %s: RELATIVE KEY %s must be unsigned"),
3071 file->name, key_field->name);
3072 }
3073 }
3074
3075 if (key_field->flag_occurs) {
3076 cb_error_x (file->key,
3077 _("file %s: RELATIVE KEY %s cannot have OCCURS"),
3078 file->name, key_field->name);
3079 }
3080
3081 if (cb_field_founder (key_field)->file == file) {
3082 cb_error_x (file->key,
3083 _("RELATIVE KEY %s cannot be in file record belonging to %s"),
3084 key_field->name, file->name);
3085 }
3086
3087 if (cb_select_working
3088 && key_field->storage != CB_STORAGE_WORKING
3089 && key_field->storage != CB_STORAGE_FILE
3090 && key_field->storage != CB_STORAGE_LOCAL) {
3091 cb_error_x (file->key,
3092 _("file %s: RELATIVE KEY %s declared outside WORKING-STORAGE"),
3093 file->name, key_field->name);
3094 }
3095 }
3096
3097 static cb_tree
3098 cb_validate_crt_status (cb_tree ref, cb_tree field_tree) {
3099 struct cb_field *field;
3100 /* LCOV_EXCL_START */
3101 if (ref == NULL || !CB_REFERENCE_P (ref)) {
3102 cobc_err_msg (_("call to '%s' with invalid parameter '%s'"),
3103 "cb_validate_crt_status", "ref");;
3104 COBC_ABORT ();
3105 }
3106 /* LCOV_EXCL_STOP */
3107 if (field_tree == NULL) {
3108 field_tree = cb_ref (ref);
3109 }
3110 if (field_tree == cb_error_node) {
3111 return NULL;
3112 }
3113 if (!CB_FIELD_P (field_tree)) {
3114 cb_error_x (ref, _("'%s' is not a valid data name"), cb_name (ref));
3115 return NULL;
3116 }
3117 field = CB_FIELD (field_tree);
3118 if (field->storage != CB_STORAGE_WORKING
3119 && field->storage != CB_STORAGE_LOCAL) {
3120 cb_error_x (ref,
3121 _("CRT STATUS item '%s' should be defined in "
3122 "WORKING-STORAGE or LOCAL-STORAGE"), field->name);
3123 return NULL;
3124 }
3125 if (CB_TREE_CATEGORY (field_tree) == CB_CATEGORY_NUMERIC) {
3126 if (field->size < 4) {
3127 cb_error_x (ref, _("'%s' CRT STATUS must have at least 4 digits"),
3128 field->name);
3129 return NULL;
3130 }
3131 }
3132 else if (field->size != 4) {
3133 cb_error_x (ref, _("'%s' CRT STATUS must be 4 characters long"),
3134 field->name);
3135 return NULL;
3136 }
3137 return ref;
3138 }
3139
3140 static void
3141 validate_file_status (cb_tree fs)
3142 {
3143 struct cb_field *fs_field;
3144 enum cb_category category;
3145
3146 /* TO-DO: If not defined, implicitly define PIC XX */
3147 if (fs == cb_error_node
3148 || cb_ref (fs) == cb_error_node) {
3149 return;
3150 }
3151
3152 if (!CB_FIELD_P (cb_ref (fs))) {
3153 cb_error (_("FILE STATUS '%s' is not a field"), CB_NAME (fs));
3154 }
3155
3156 fs_field = CB_FIELD_PTR (fs);
3157 category = cb_tree_category (CB_TREE (fs_field));
3158 if (category == CB_CATEGORY_ALPHANUMERIC) {
3159 /* ok */
3160 } else if (category == CB_CATEGORY_NUMERIC) {
3161 if (fs_field->pic
3162 && fs_field->pic->scale != 0) {
3163 cb_error_x (fs, _("FILE STATUS '%s' may not be a decimal or have a PIC with a P"),
3164 CB_NAME (fs));
3165 }
3166 cb_warning_x (cb_warn_additional, fs, _("FILE STATUS '%s' is a numeric field, but I-O status codes are not numeric in general"),
3167 CB_NAME (fs));
3168 } else {
3169 cb_error_x (fs, _("FILE STATUS '%s' must be alphanumeric or numeric field"),
3170 CB_NAME (fs));
3171 return;
3172 }
3173
3174 if (fs_field->usage != CB_USAGE_DISPLAY) {
3175 cb_error_x (fs, _("FILE STATUS '%s' must be USAGE DISPLAY"),
3176 CB_NAME (fs));
3177 }
3178
3179 /* Check file status is two characters long */
3180 if (fs_field->size != 2) {
3181 cb_error_x (fs, _("FILE STATUS '%s' must be 2 characters long"),
3182 CB_NAME (fs));
3183 }
3184
3185 if (fs_field->storage != CB_STORAGE_WORKING
3186 && fs_field->storage != CB_STORAGE_LOCAL
3187 && fs_field->storage != CB_STORAGE_LINKAGE) {
3188 cb_error_x (fs, _("FILE STATUS '%s' must be in WORKING-STORAGE, LOCAL-STORAGE or LINKAGE"),
3189 CB_NAME (fs));
3190 }
3191
3192 if (fs_field->flag_odo_relative) {
3193 cb_error_x (fs, _("FILE STATUS '%s' may not be located after an OCCURS DEPENDING field"),
3194 CB_NAME (fs));
3195 }
3196 }
3197
3198 static void
3199 create_implicit_assign_dynamic_var (struct cb_program * const prog,
3200 cb_tree assign)
3201 {
3202 cb_tree x;
3203 struct cb_field *p;
3204 const char *assign_name = CB_NAME (assign);
3205
3206 cb_warning (cb_warn_implicit_define,
3207 _("variable '%s' will be implicitly defined"), CB_NAME (assign));
3208 x = cb_build_implicit_field (assign, COB_FILE_MAX);
3209 p = CB_FIELD (x);
3210 #if 0
3211 p->count++;
3212 #endif
3213 x = CB_TREE (build_literal (CB_CATEGORY_ALPHANUMERIC, assign_name, strlen (assign_name)));
3214 p->values = CB_LIST_INIT (x);
3215 if (prog->working_storage) {
3216 CB_FIELD_ADD (prog->working_storage, p);
3217 } else {
3218 prog->working_storage = p;
3219 }
3220 }
3221
3222 static void
3223 process_undefined_assign_name (struct cb_file * const f,
3224 struct cb_program * const prog)
3225 {
3226 cb_tree assign = f->assign;
3227 cb_tree l;
3228 cb_tree ll;
3229
3230 if (f->assign_type != CB_ASSIGN_VARIABLE_DEFAULT) {
3231 /* An error is emitted later */
3232 return;
3233 }
3234
3235 /*
3236 Either create a variable or treat the assign name as an external-file-
3237 name.
3238 */
3239 if (cb_implicit_assign_dynamic_var) {
3240 cb_verify_x (CB_TREE (f), cb_assign_variable, _("ASSIGN variable"));
3241 create_implicit_assign_dynamic_var (prog, assign);
3242 } else {
3243 /* Remove reference */
3244 for (l = prog->reference_list;
3245 CB_VALUE (l) != assign && CB_VALUE (CB_CHAIN (l)) != assign;
3246 l = CB_CHAIN (l));
3247 if (CB_VALUE (l) == assign) {
3248 prog->reference_list = CB_CHAIN (l);
3249 } else {
3250 ll = CB_CHAIN (CB_CHAIN (l));
3251 cobc_parse_free (CB_CHAIN (l));
3252 CB_CHAIN (l) = ll;
3253 }
3254
3255 /* Reinterpret word */
3256 f->assign = build_external_assignment_name (assign);
3257 }
3258 }
3259
3260 /* Ensure ASSIGN name refers to a valid identifier */
3261 static void
3262 validate_assign_name (struct cb_file * const f,
3263 struct cb_program * const prog)
3264 {
3265 cb_tree assign = f->assign;
3266 cb_tree x;
3267 struct cb_field *p;
3268
3269 if (!assign) {
3270 return;
3271 }
3272
3273 if (!CB_REFERENCE_P (assign)) {
3274 return;
3275 }
3276
3277 /* Error if assign name is same as a file name */
3278 for (x = prog->file_list; x; x = CB_CHAIN (x)) {
3279 if (!strcmp (CB_FILE (CB_VALUE (x))->name,
3280 CB_NAME (assign))) {
3281 redefinition_error (assign);
3282 }
3283 }
3284
3285 /* If assign is a 78-level, change assign to the 78-level's literal. */
3286 p = check_level_78 (CB_NAME (assign));
3287 if (p) {
3288 char *c = (char *)CB_LITERAL(CB_VALUE(p->values))->data;
3289 f->assign = CB_TREE (build_literal (CB_CATEGORY_ALPHANUMERIC, c, strlen (c)));
3290 return;
3291 }
3292
3293 if (CB_WORD_COUNT (assign) == 0) {
3294 process_undefined_assign_name (f, prog);
3295 } else {
3296 /*
3297 We now know we have a variable, so can validate whether it is
3298 is allowed
3299 */
3300 if (f->flag_assign_no_keyword) {
3301 cb_verify_x (CB_TREE (f), cb_assign_variable, _("ASSIGN variable"));
3302 }
3303
3304 x = cb_ref (assign);
3305 if (CB_FIELD_P (x) && CB_FIELD (x)->level == 88) {
3306 cb_error_x (assign, _("ASSIGN data item '%s' is invalid"),
3307 CB_NAME (assign));
3308 }
3309 }
3310 }
3311
3312 void
3313 cb_validate_program_data (struct cb_program *prog)
3314 {
3315 cb_tree l, x;
3316 struct cb_field *p;
3317 struct cb_field *q;
3318 struct cb_field *field;
3319 char buff[COB_MINI_BUFF];
3320
3321 prog->report_list = cb_list_reverse (prog->report_list);
3322
3323 for (l = prog->report_list; l; l = CB_CHAIN (l)) {
3324 /* Set up LINE-COUNTER / PAGE-COUNTER */
3325 struct cb_report *rep = CB_REPORT (CB_VALUE (l));
3326 if (rep->line_counter == NULL) {
3327 snprintf (buff, (size_t)COB_MINI_MAX,
3328 "LINE-COUNTER %s", rep->cname);
3329 x = cb_build_field (cb_build_reference (buff));
3330 CB_FIELD (x)->usage = CB_USAGE_UNSIGNED_INT;
3331 CB_FIELD (x)->values = CB_LIST_INIT (cb_zero);
3332 CB_FIELD (x)->count++;
3333 cb_validate_field (CB_FIELD (x));
3334 rep->line_counter = cb_build_field_reference (CB_FIELD (x), NULL);
3335 CB_FIELD_ADD (prog->working_storage, CB_FIELD (x));
3336 }
3337 if (rep->page_counter == NULL) {
3338 snprintf (buff, (size_t)COB_MINI_MAX,
3339 "PAGE-COUNTER %s", rep->cname);
3340 x = cb_build_field (cb_build_reference (buff));
3341 CB_FIELD (x)->usage = CB_USAGE_UNSIGNED_INT;
3342 CB_FIELD (x)->values = CB_LIST_INIT (cb_zero);
3343 CB_FIELD (x)->count++;
3344 cb_validate_field (CB_FIELD (x));
3345 rep->page_counter = cb_build_field_reference (CB_FIELD (x), NULL);
3346 CB_FIELD_ADD (prog->working_storage, CB_FIELD (x));
3347 }
3348 }
3349
3350 prog->file_list = cb_list_reverse (prog->file_list);
3351
3352 for (l = prog->file_list; l; l = CB_CHAIN (l)) {
3353 struct cb_file *file;
3354 file = CB_FILE (CB_VALUE (l));
3355 if (!file->flag_finalized) {
3356 finalize_file (file, NULL);
3357 }
3358 }
3359
3360 /* Build undeclared assignment names now */
3361 for (l = prog->file_list; l; l = CB_CHAIN (l)) {
3362 validate_assign_name (CB_FILE (CB_VALUE (l)), prog);
3363 }
3364
3365 if (prog->cursor_pos) {
3366 x = cb_ref (prog->cursor_pos);
3367 if (x == cb_error_node) {
3368 prog->cursor_pos = NULL;
3369 } else if (CB_FIELD(x)->size != 6 && CB_FIELD(x)->size != 4) {
3370 cb_error_x (prog->cursor_pos, _("'%s' CURSOR must be 4 or 6 characters long"),
3371 cb_name (prog->cursor_pos));
3372 prog->cursor_pos = NULL;
3373 }
3374 }
3375 if (prog->crt_status) {
3376 prog->crt_status = cb_validate_crt_status (prog->crt_status, NULL);
3377 } else {
3378 /* TO-DO: Add to registers list */
3379 l = cb_build_reference ("COB-CRT-STATUS");
3380 x = cb_try_ref (l);
3381 if (x == cb_error_node) {
3382 p = CB_FIELD (cb_build_field (l));
3383 p->usage = CB_USAGE_DISPLAY;
3384 p->pic = CB_PICTURE (cb_build_picture ("9(4)"));
3385 cb_validate_field (p);
3386 p->flag_no_init = 1;
3387 /* Do not initialize/bump ref count here
3388 p->values = CB_LIST_INIT (cb_zero);
3389 p->count++;
3390 */
3391 CB_FIELD_ADD (prog->working_storage, p);
3392 prog->crt_status = l;
3393 } else {
3394 prog->crt_status = cb_validate_crt_status (l, x);
3395 }
3396 }
3397
3398 /* Resolve all references so far */
3399 for (l = cb_list_reverse (prog->reference_list); l; l = CB_CHAIN (l)) {
3400 cb_ref (CB_VALUE (l));
3401 }
3402
3403 /* Check ODO items */
3404 for (l = cb_depend_check; l; l = CB_CHAIN (l)) {
3405 struct cb_field *depfld = NULL;
3406 unsigned int odo_level = 0;
3407 cb_tree xerr = NULL;
3408 x = CB_VALUE (l);
3409 if (x == NULL || x == cb_error_node) {
3410 continue;
3411 }
3412 q = CB_FIELD_PTR (x);
3413 if (cb_validate_one (q->depending)) {
3414 q->depending = cb_error_node;
3415 } else if (cb_ref (q->depending) != cb_error_node) {
3416 depfld = CB_FIELD_PTR (q->depending);
3417 }
3418 /* The data item that contains a OCCURS DEPENDING clause must be
3419 the last data item in the group */
3420 for (p = q; ; p = p->parent) {
3421 if (p->depending) {
3422 if (odo_level > 0
3423 && !cb_flag_odoslide) {
3424 xerr = x;
3425 cb_error_x (x,
3426 _ ("'%s' cannot have nested OCCURS DEPENDING"),
3427 cb_name (x));
3428 }
3429 odo_level++;
3430 }
3431 p->odo_level = odo_level;
3432 if (!p->parent) {
3433 break;
3434 }
3435 for (; p->sister; p = p->sister) {
3436 if (p->sister->level == 66) continue;
3437 if (p->sister == depfld && x != xerr) {
3438 xerr = x;
3439 cb_error_x (x,
3440 _("'%s' OCCURS DEPENDING ON field item invalid here"),
3441 p->sister->name);
3442 }
3443 if (!p->sister->redefines) {
3444 if (!cb_complex_odo
3445 && x != xerr) {
3446 xerr = x;
3447 cb_error_x (x,
3448 _ ("'%s' cannot have OCCURS DEPENDING because of '%s'"),
3449 cb_name (x), p->sister->name);
3450 break;
3451 }
3452 p->flag_odo_relative = 1;
3453 }
3454 }
3455 }
3456
3457 /* If the field is GLOBAL, then the ODO must also be GLOBAL */
3458 if (q->flag_is_global && depfld) {
3459 if (!depfld->flag_is_global) {
3460 cb_error_x (x, _("'%s' OCCURS DEPENDING ON item must have GLOBAL attribute"),
3461 depfld->name);
3462 }
3463 }
3464 }
3465 cb_depend_check = NULL;
3466 cb_needs_01 = 0;
3467
3468 /* file definition checks */
3469 for (l = prog->file_list; l; l = CB_CHAIN (l)) {
3470 struct cb_file *file = CB_FILE (CB_VALUE (l));
3471 if (file->flag_external) {
3472 if (CB_VALID_TREE (file->password)
3473 && !CB_FIELD (cb_ref(file->password))->flag_external) {
3474 cb_error_x (file->password, _("PASSWORD '%s' for EXTERNAL file '%s' must have EXTERNAL attribute"),
3475 CB_NAME (file->password), file->name);
3476 }
3477 }
3478 if (CB_VALID_TREE (file->record_depending)) {
3479 validate_record_depending (file->record_depending);
3480 }
3481 if (file->organization == COB_ORG_RELATIVE && file->key
3482 && cb_ref (file->key) != cb_error_node) {
3483 validate_relative_key_field (file);
3484 }
3485 if (file->file_status) {
3486 validate_file_status (file->file_status);
3487 }
3488 }
3489
3490 /* check alphabets */
3491 for (l = current_program->alphabet_name_list; l; l = CB_CHAIN(l)) {
3492 struct cb_alphabet_name *alphabet = CB_ALPHABET_NAME (CB_VALUE(l));
3493 if (alphabet->alphabet_type == CB_ALPHABET_LOCALE) {
3494 x = cb_ref (alphabet->custom_list);
3495 if (x != cb_error_node && !CB_LOCALE_NAME_P(x)) {
3496 cb_error_x (alphabet->custom_list, _("'%s' is not a locale-name"),
3497 cb_name(x));
3498 alphabet->custom_list = cb_error_node;
3499 }
3500 }
3501 }
3502
3503 /* Resolve APPLY COMMIT */
3504 if (CB_VALID_TREE(prog->apply_commit)) {
3505 for (l = prog->apply_commit; l; l = CB_CHAIN(l)) {
3506 cb_tree l2 = CB_VALUE (l);
3507 x = cb_ref (l2);
3508 if (x != cb_error_node) {
3509 for (l2 = prog->apply_commit; l2 != l; l2 = CB_CHAIN(l2)) {
3510 if (cb_ref (CB_VALUE (l2)) == x) {
3511 cb_error_x (l,
3512 _("duplicate APPLY COMMIT target: '%s'"),
3513 cb_name (CB_VALUE (l)));
3514 x = cb_error_node;
3515 break;
3516 }
3517 }
3518 }
3519 if (x == cb_error_node) {
3520 continue;
3521 }
3522 if (CB_FILE_P (x)) {
3523 struct cb_file *file = CB_FILE (x);
3524 if (file->organization == COB_ORG_SORT) {
3525 cb_error_x (l,
3526 _("APPLY COMMIT statement invalid for SORT file"));
3527 } else if (file->flag_report) {
3528 cb_error_x (l,
3529 _("APPLY COMMIT statement invalid for REPORT file"));
3530 }
3531 } else if (CB_FIELD_P (x)) {
3532 field = CB_FIELD (x);
3533 if (field->storage != CB_STORAGE_WORKING
3534 && field->storage != CB_STORAGE_LOCAL) {
3535 cb_error_x (l,
3536 _("APPLY COMMIT item '%s' should be defined in "
3537 "WORKING-STORAGE or LOCAL-STORAGE"), field->name);
3538 }
3539 if (field->level != 01 && field->level != 77) {
3540 cb_error_x (l, _("'%s' not level 01 or 77"), field->name);
3541 #if 0 /* currently not part of the rules */
3542 } else if (field->flag_item_based || field->flag_external) {
3543 cb_error_x (l, _("'%s' cannot be BASED/EXTERNAL"), field->name);
3544 #endif
3545 } else if (field->redefines) {
3546 cb_error_x (l, _("'%s' REDEFINES field not allowed here"),
3547 field->name);
3548 }
3549 } else {
3550 cb_error_x (l, _("item not allowed here: '%s'"), cb_name (x));
3551 }
3552 }
3553 }
3554 }
3555
3556
3557 static int
3558 error_if_subscript_or_refmod (cb_tree ref, const char *name)
3559 {
3560 int error = 0;
3561
3562 if (CB_REFERENCE (ref)->subs) {
3563 cb_error_x (ref, _("%s may not be subscripted"), name);
3564 error = 1;
3565 }
3566 if (CB_REFERENCE (ref)->offset) {
3567 cb_error_x (ref, _("%s may not be reference modified"), name);
3568 error = 1;
3569 }
3570
3571 return error;
3572 }
3573
3574 static int
3575 has_sub_reference (struct cb_field *fld)
3576 {
3577 struct cb_field *f;
3578
3579 if (fld->count) {
3580 return 1;
3581 }
3582 if (fld->validation) {
3583 for (f = fld->validation; f; f = f->sister) {
3584 if (f->count) {
3585 return 1;
3586 }
3587 }
3588 } else {
3589 for (f = fld->children; f; f = f->sister) {
3590 if (has_sub_reference (f)) {
3591 return 1;
3592 }
3593 }
3594 for (f = fld->sister; f; f = f->sister) {
3595 if (f->redefines == fld) {
3596 if (has_sub_reference (f)) {
3597 return 1;
3598 }
3599 }
3600 }
3601 }
3602 return 0;
3603 }
3604
3605 /* Resolve DEBUG references, return necessary size for DEBUG-CONTENTS */
3606 static int
3607 cb_resolve_debug_refs (struct cb_program *prog, int size)
3608 {
3609 cb_tree l;
3610 cb_tree x;
3611 cb_tree v;
3612
3613 /* For data items, we may need to adjust the size of DEBUG-CONTENTS directly,
3614 for file items from its maximum length */
3615 for (l = prog->debug_list; l; l = CB_CHAIN (l)) {
3616 x = CB_VALUE (l);
3617 (void)cb_set_ignore_error (CB_REFERENCE (x)->flag_ignored);
3618 v = cb_ref (x);
3619 if (v == cb_error_node) {
3620 continue;
3621 }
3622 current_section = CB_REFERENCE (x)->section;
3623 current_paragraph = CB_REFERENCE (x)->paragraph;
3624 switch (CB_TREE_TAG (v)) {
3625 case CB_TAG_LABEL:
3626 if (!CB_LABEL (v)->flag_real_label) {
3627 cb_error_x (x, _("DEBUGGING target invalid: '%s'"),
3628 cb_name (x));
3629 } else if (CB_LABEL (v)->flag_debugging_mode) {
3630 cb_error_x (x, _("duplicate DEBUGGING target: '%s'"),
3631 cb_name (x));
3632 } else if (prog->all_procedure) {
3633 cb_error_x (x, _("DEBUGGING target already specified with ALL PROCEDURES: '%s'"),
3634 cb_name (x));
3635 CB_LABEL (v)->flag_debugging_mode = 1;
3636 } else {
3637 CB_LABEL (v)->debug_section =
3638 CB_REFERENCE (x)->debug_section;
3639 CB_LABEL (v)->flag_debugging_mode = 1;
3640 }
3641 break;
3642 case CB_TAG_FILE:
3643 if (CB_FILE (v)->record_max > size) {
3644 size = CB_FILE (v)->record_max;
3645 }
3646 break;
3647 case CB_TAG_CD:
3648 if (CB_CD (v)->record && CB_CD (v)->record->size > size) {
3649 size = CB_CD(v)->record->size;
3650 }
3651 break;
3652 case CB_TAG_FIELD:
3653 if (!error_if_subscript_or_refmod (x, _("DEBUGGING target"))) {
3654 if (CB_FIELD (v)->size > size) {
3655 size = CB_FIELD (v)->size;
3656 }
3657 }
3658 break;
3659 default:
3660 cb_error_x (x, _("'%s' is not a valid DEBUGGING target"),
3661 cb_name (x));
3662 break;
3663 }
3664 }
3665 /* reset error handling */
3666 cb_set_ignore_error (0);
3667
3668 return size;
3669 }
3670
3671 /* Resolve all labels */
3672 static void
3673 cb_validate_labels (struct cb_program *prog)
3674 {
3675 cb_tree l;
3676 cb_tree x;
3677 cb_tree v;
3678
3679 for (l = cb_list_reverse (prog->label_list); l; l = CB_CHAIN (l)) {
3680 x = CB_VALUE (l);
3681 (void)cb_set_ignore_error (CB_REFERENCE (x)->flag_ignored);
3682 v = cb_ref (x);
3683 /* cb_error_node -> reference not defined, message raised in cb_ref() */
3684 if (v == cb_error_node) {
3685 continue;
3686 }
3687 current_section = CB_REFERENCE (x)->section;
3688 current_paragraph = CB_REFERENCE (x)->paragraph;
3689 /* Check refs in to / out of DECLARATIVES */
3690 if (CB_LABEL_P (v)) {
3691 if (CB_REFERENCE (x)->flag_in_decl &&
3692 !CB_LABEL (v)->flag_declaratives) {
3693 /* verify reference-out-of-declaratives */
3694 switch (cb_reference_out_of_declaratives) {
3695 case CB_OK:
3696 break;
3697 case CB_ERROR:
3698 cb_error_x (x, _("'%s' is not in DECLARATIVES"),
3699 CB_LABEL (v)->name);
3700 break;
3701 case CB_WARNING:
3702 cb_warning_x (cb_warn_dialect, x,
3703 _("'%s' is not in DECLARATIVES"),
3704 CB_LABEL (v)->name);
3705 break;
3706 default:
3707 break;
3708 }
3709 }
3710
3711 /* GO TO into DECLARATIVES is not allowed */
3712 if (CB_LABEL (v)->flag_declaratives &&
3713 !CB_REFERENCE (x)->flag_in_decl &&
3714 !CB_REFERENCE (x)->flag_decl_ok) {
3715 cb_error_x (x, _("invalid reference to '%s' (in DECLARATIVES)"),
3716 CB_LABEL (v)->name);
3717 }
3718
3719 CB_LABEL (v)->flag_begin = 1;
3720 if (CB_REFERENCE (x)->length) {
3721 CB_LABEL (v)->flag_return = 1;
3722 }
3723 } else {
3724 cb_error_x (x, _("'%s' is not a procedure name"), cb_name (x));
3725 }
3726 }
3727 /* reset error handling */
3728 cb_set_ignore_error (0);
3729 }
3730
3731
3732 void
3733 cb_validate_program_body (struct cb_program *prog)
3734 {
3735 cb_tree l;
3736 cb_tree x;
3737 cb_tree v;
3738 struct cb_label *save_section;
3739 struct cb_label *save_paragraph;
3740 struct cb_alter_id *aid;
3741 struct cb_label *l1;
3742 struct cb_label *l2;
3743 struct cb_field *f, *ret_fld;
3744
3745 /* Check reference to ANY LENGTH items */
3746 if (prog->linkage_storage) {
3747 for (f = prog->linkage_storage; f; f = f->sister) {
3748
3749 /* only check fields with ANY LENGTH;
3750 RETURNING is already a valid reference */
3751 if (!f->flag_any_length
3752 || f->flag_is_returning) {
3753 continue;
3754 }
3755
3756 /* ignore fields that are part of main entry USING */
3757 for (l = CB_VALUE (CB_VALUE (prog->entry_list)); l; l = CB_CHAIN (l)) {
3758 x = CB_VALUE (l);
3759 if (CB_VALID_TREE (x) && cb_ref (x) != cb_error_node) {
3760 if (f == CB_FIELD (cb_ref (x))) {
3761 break;
3762 }
3763 }
3764 }
3765 if (!l) {
3766 cb_error_x (CB_TREE (f),
3767 _("'%s' ANY LENGTH item must be a formal parameter"),
3768 f->name);
3769 }
3770 }
3771 }
3772
3773 /* Validate entry points */
3774
3775 /* Check dangling LINKAGE items */
3776 if (cb_warn_opt_val[cb_warn_linkage]
3777 && prog->linkage_storage) {
3778 if (prog->returning
3779 && cb_ref (prog->returning) != cb_error_node) {
3780 ret_fld = CB_FIELD (cb_ref (prog->returning));
3781 if (ret_fld->redefines) {
3782 /* error, but we check this in parser.y already and just go on here */
3783 ret_fld = ret_fld->redefines;
3784 }
3785 } else {
3786 ret_fld = NULL;
3787 }
3788 for (v = prog->entry_list; v; v = CB_CHAIN (v)) {
3789 for (f = prog->linkage_storage; f; f = f->sister) {
3790
3791 /* ignore RETURNING fields and fields that REDEFINES */
3792 if (f == ret_fld
3793 || f->redefines) {
3794 continue;
3795 }
3796
3797 /* ignore fields that are part of current entry USING */
3798 for (l = CB_VALUE (CB_VALUE (v)); l; l = CB_CHAIN (l)) {
3799 x = CB_VALUE (l);
3800 if (CB_VALID_TREE (x) && cb_ref (x) != cb_error_node) {
3801 if (f == CB_FIELD (cb_ref (x))) {
3802 break;
3803 }
3804 }
3805 }
3806 if (l) {
3807 continue;
3808 }
3809
3810 /* check if field or its cildren have any actual reference,
3811 otherwise the warning is useless */
3812 if (has_sub_reference(f)) {
3813 cb_warning_x (cb_warn_linkage, CB_TREE (f),
3814 _("LINKAGE item '%s' is not a PROCEDURE USING parameter"), f->name);
3815 }
3816 }
3817 }
3818 }
3819
3820 save_section = current_section;
3821 save_paragraph = current_paragraph;
3822
3823 /* Resolve all labels */
3824 cb_validate_labels (prog);
3825
3826 if (prog->flag_debugging) {
3827 /* Resolve DEBUGGING references and calculate DEBUG-CONTENTS size */
3828 /* Basic size of DEBUG-CONTENTS is DFLT_DEBUG_CONTENTS_SIZE */
3829 int debug_contents_size = cb_resolve_debug_refs (prog, DFLT_DEBUG_CONTENTS_SIZE);
3830
3831 /* If necessary, adjust size of DEBUG-CONTENTS (and DEBUG-ITEM) */
3832 if (debug_contents_size != DFLT_DEBUG_CONTENTS_SIZE) {
3833 f = CB_FIELD_PTR (cb_debug_contents);
3834 f->size = debug_contents_size;
3835 f->memory_size = debug_contents_size;
3836
3837 f = CB_FIELD_PTR (cb_debug_item);
3838 f->size += debug_contents_size - DFLT_DEBUG_CONTENTS_SIZE;
3839 f->memory_size += debug_contents_size - DFLT_DEBUG_CONTENTS_SIZE;
3840 }
3841 }
3842
3843 /* Build ALTER ids - We need to remove duplicates */
3844 for (l = prog->alter_list; l; l = CB_CHAIN (l)) {
3845 if (CB_PURPOSE (l) == cb_error_node) {
3846 continue;
3847 }
3848 if (CB_VALUE (l) == cb_error_node) {
3849 continue;
3850 }
3851 x = CB_PURPOSE (l);
3852 v = CB_VALUE (l);
3853 if (CB_REFERENCE (x)->value == cb_error_node
3854 || CB_REFERENCE (x)->flag_ignored) {
3855 continue;
3856 }
3857 if (CB_REFERENCE (v)->value == cb_error_node
3858 || CB_REFERENCE (v)->flag_ignored) {
3859 continue;
3860 }
3861 l1 = CB_LABEL (CB_REFERENCE (x)->value);
3862 l2 = CB_LABEL (CB_REFERENCE (v)->value);
3863 current_section = CB_REFERENCE (x)->section;
3864 current_paragraph = CB_REFERENCE (x)->paragraph;
3865 /* First statement in paragraph must be a GO TO */
3866 if (!l1->flag_first_is_goto) {
3867 cb_error_x (x, _("'%s' is not an alterable paragraph"),
3868 l1->name);
3869 continue;
3870 }
3871 for (aid = l1->alter_gotos; aid; aid = aid->next) {
3872 if (aid->goto_id == l2->id) {
3873 break;
3874 }
3875 }
3876 if (!aid) {
3877 aid = cobc_parse_malloc (sizeof(struct cb_alter_id));
3878 aid->next = l1->alter_gotos;
3879 aid->goto_id = l2->id;
3880 l1->alter_gotos = aid;
3881 }
3882 for (aid = prog->alter_gotos; aid; aid = aid->next) {
3883 if (aid->goto_id == l1->id) {
3884 break;
3885 }
3886 }
3887 if (!aid) {
3888 aid = cobc_parse_malloc (sizeof(struct cb_alter_id));
3889 aid->next = prog->alter_gotos;
3890 aid->goto_id = l1->id;
3891 prog->alter_gotos = aid;
3892 }
3893 }
3894
3895 current_section = save_section;
3896 current_paragraph = save_paragraph;
3897 cobc_cs_check = 0;
3898
3899 prog->exec_list = cb_list_reverse (prog->exec_list);
3900 }
3901
3902 /* General */
3903
3904 static COB_INLINE COB_A_INLINE void
3905 cb_copy_source_reference (cb_tree target, cb_tree x)
3906 {
3907 target->source_file = x->source_file;
3908 target->source_line = x->source_line;
3909 target->source_column = x->source_column;
3910 }
3911
3912 /* Expressions */
3913
3914 static void
3915 cb_expr_init (void)
3916 {
3917 if (initialized == 0) {
3918 initialized = 1;
3919 /* Init stack */
3920 expr_stack_size = START_STACK_SIZE;
3921 expr_stack = cobc_main_malloc (sizeof (struct expr_node) * START_STACK_SIZE);
3922 } else {
3923 memset (expr_stack, 0, expr_stack_size * sizeof (struct expr_node));
3924 }
3925 expr_op = 0;
3926 expr_lh = NULL;
3927 /* First three entries are dummies */
3928 expr_index = 3;
3929 }
3930
3931 static int
3932 expr_chk_cond (cb_tree expr_1, cb_tree expr_2)
3933 {
3934 struct cb_field *f1;
3935 struct cb_field *f2;
3936 int is_ptr_1;
3937 int is_ptr_2;
3938
3939 /* 88 level is invalid here */
3940 /* Likewise combination of pointer and non-pointer */
3941 is_ptr_1 = 0;
3942 is_ptr_2 = 0;
3943 if (CB_REF_OR_FIELD_P (expr_1)) {
3944 f1 = CB_FIELD_PTR (expr_1);
3945 if (f1->level == 88) {
3946 return 1;
3947 }
3948 if (f1->flag_is_pointer) {
3949 is_ptr_1 = 1;
3950 }
3951 } else if (CB_CAST_P (expr_1)) {
3952 switch (CB_CAST (expr_1)->cast_type) {
3953 case CB_CAST_ADDRESS:
3954 case CB_CAST_ADDR_OF_ADDR:
3955 case CB_CAST_PROGRAM_POINTER:
3956 is_ptr_1 = 1;
3957 break;
3958 default:
3959 break;
3960 }
3961 } else if (expr_1 == cb_null) {
3962 is_ptr_1 = 1;
3963 }
3964 if (CB_REF_OR_FIELD_P (expr_2)) {
3965 f2 = CB_FIELD_PTR (expr_2);
3966 if (f2->level == 88) {
3967 return 1;
3968 }
3969 if (f2->flag_is_pointer) {
3970 is_ptr_2 = 1;
3971 }
3972 } else if (CB_CAST_P (expr_2)) {
3973 switch (CB_CAST (expr_2)->cast_type) {
3974 case CB_CAST_ADDRESS:
3975 case CB_CAST_ADDR_OF_ADDR:
3976 case CB_CAST_PROGRAM_POINTER:
3977 is_ptr_2 = 1;
3978 break;
3979 default:
3980 break;
3981 }
3982 } else if (expr_2 == cb_null) {
3983 is_ptr_2 = 1;
3984 }
3985 return is_ptr_1 ^ is_ptr_2;
3986 }
3987
3988 static int
3989 expr_reduce (int token)
3990 {
3991 /* Example:
3992 * index: -3 -2 -1 0
3993 * token: 'x' '*' 'x' '+' ...
3994 */
3995
3996 int op;
3997
3998 while (expr_prio[TOKEN (-2)] <= expr_prio[token]) {
3999 /* Reduce the expression depending on the last operator */
4000 op = TOKEN (-2);
4001 switch (op) {
4002 case 'x':
4003 return 0;
4004
4005 case '+':
4006 case '-':
4007 case '*':
4008 case '/':
4009 case '^':
4010 /* Arithmetic operators: 'x' op 'x' */
4011 if (TOKEN (-1) != 'x' || TOKEN (-3) != 'x') {
4012 return -1;
4013 }
4014 TOKEN (-3) = 'x';
4015 VALUE (-3) = cb_build_binary_op (VALUE (-3), op, VALUE (-1));
4016 expr_index -= 2;
4017 break;
4018
4019 case '!':
4020 /* Negation: '!' 'x' */
4021 if (TOKEN (-1) != 'x') {
4022 return -1;
4023 }
4024 /* 'x' '=' 'x' '|' '!' 'x' */
4025 if (expr_lh) {
4026 if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
4027 VALUE (-1) = cb_build_binary_op (expr_lh, expr_op, VALUE (-1));
4028 }
4029 }
4030 TOKEN (-2) = 'x';
4031 VALUE (-2) = CB_BUILD_NEGATION (VALUE (-1));
4032 expr_index -= 1;
4033 break;
4034
4035 case '&':
4036 case '|':
4037 /* Logical AND/OR: 'x' op 'x' */
4038 if (TOKEN (-1) != 'x' || TOKEN (-3) != 'x') {
4039 return -1;
4040 }
4041 /* 'x' '=' 'x' '|' 'x' */
4042 if (expr_lh) {
4043 if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
4044 VALUE (-1) = cb_build_binary_op (expr_lh, expr_op, VALUE (-1));
4045 }
4046 if (CB_TREE_CLASS (VALUE (-3)) != CB_CLASS_BOOLEAN) {
4047 VALUE (-3) = cb_build_binary_op (expr_lh, expr_op, VALUE (-3));
4048 }
4049 }
4050 TOKEN (-3) = 'x';
4051 VALUE (-3) = cb_build_binary_op (VALUE (-3), op,
4052 VALUE (-1));
4053 expr_index -= 2;
4054 break;
4055
4056 case '(':
4057 case ')':
4058 return 0;
4059
4060 default:
4061 /* Relational operators */
4062 if (TOKEN (-1) != 'x') {
4063 return -1;
4064 }
4065 switch (TOKEN (-3)) {
4066 case 'x':
4067 /* Simple condition: 'x' op 'x' */
4068 if (VALUE (-3) == cb_error_node ||
4069 VALUE (-1) == cb_error_node) {
4070 VALUE (-3) = cb_error_node;
4071 } else {
4072 expr_lh = VALUE (-3);
4073 if (expr_chk_cond (expr_lh, VALUE (-1))) {
4074 VALUE (-3) = cb_error_node;
4075 return 1;
4076 }
4077 expr_op = op;
4078 TOKEN (-3) = 'x';
4079 if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
4080 VALUE (-3) = cb_build_binary_op (expr_lh, op, VALUE (-1));
4081 #if 0 /* Note: We loose the source reference here if
4082 the result is true/false, for example because of
4083 comparing 'A' = 'B'. As we now have cb_false
4084 in VALUE (-3) we should not add the reference there.
4085 CHECKME: Should we store the value as PAIR with a new
4086 cb_tree containing the reference and unpack it
4087 everywhere or is there a better option to find?
4088 See: Test syn_misc.at - Constant Expressions (2)
4089 */
4090 cb_copy_source_reference (VALUE (-3), expr_lh);
4091 #endif
4092 } else {
4093 VALUE (-3) = VALUE (-1);
4094 }
4095 }
4096 expr_index -= 2;
4097 break;
4098 case '&':
4099 case '|':
4100 /* Complex condition: 'x' '=' 'x' '|' op 'x' */
4101 if (VALUE (-1) == cb_error_node) {
4102 VALUE (-2) = cb_error_node;
4103 } else {
4104 expr_op = op;
4105 TOKEN (-2) = 'x';
4106 if (CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN && expr_lh) {
4107 VALUE (-2) = cb_build_binary_op (expr_lh, op, VALUE (-1));
4108 } else {
4109 VALUE (-2) = VALUE (-1);
4110 }
4111 }
4112 expr_index -= 1;
4113 break;
4114 default:
4115 return -1;
4116 }
4117 break;
4118 }
4119 }
4120
4121 /* Handle special case "op OR x AND" */
4122 if (token == '&' && TOKEN (-2) == '|'
4123 && CB_TREE_CLASS (VALUE (-1)) != CB_CLASS_BOOLEAN) {
4124 /* LCOV_EXCL_START */
4125 if (!expr_lh) {
4126 /* untranslated as highly unlikely to be raised */
4127 cobc_err_msg ("missing left-hand-expression");
4128 COBC_ABORT ();
4129 }
4130 /* LCOV_EXCL_STOP */
4131 TOKEN (-1) = 'x';
4132 VALUE (-1) = cb_build_binary_op (expr_lh, expr_op, VALUE (-1));
4133 }
4134
4135 return 0;
4136 }
4137
4138 static void
4139 cb_expr_shift_sign (const int op)
4140 {
4141 int have_not;
4142
4143 if (TOKEN (-1) == '!') {
4144 have_not = 1;
4145 expr_index--;
4146 } else {
4147 have_not = 0;
4148 }
4149 (void)expr_reduce ('=');
4150 if (TOKEN (-1) == 'x') {
4151 VALUE (-1) = cb_build_binary_op (VALUE (-1), op, cb_zero);
4152 if (have_not) {
4153 VALUE (-1) = CB_BUILD_NEGATION (VALUE (-1));
4154 }
4155 }
4156 }
4157
4158 static void
4159 cb_expr_shift_class (const char *name)
4160 {
4161 int have_not;
4162
4163 if (TOKEN (-1) == '!') {
4164 have_not = 1;
4165 expr_index--;
4166 } else {
4167 have_not = 0;
4168 }
4169 (void)expr_reduce ('=');
4170 if (TOKEN (-1) == 'x') {
4171 VALUE (-1) = CB_BUILD_FUNCALL_1 (name, VALUE (-1));
4172 if (have_not) {
4173 VALUE (-1) = CB_BUILD_NEGATION (VALUE (-1));
4174 }
4175 }
4176 }
4177
4178 static int
4179 binary_op_is_relational (const struct cb_binary_op * const op)
4180 {
4181 return op->op == '='
4182 || op->op == '>'
4183 || op->op == '<'
4184 || op->op == '['
4185 || op->op == ']'
4186 || op->op == '~';
4187 }
4188
4189 static void
4190 cb_expr_shift (int token, cb_tree value)
4191 {
4192 switch (token) {
4193 case 'M':
4194 break;
4195 case 'x':
4196 /* Sign ZERO condition */
4197 if (value == cb_zero) {
4198 if (TOKEN (-1) == 'x' || TOKEN (-1) == '!') {
4199 cb_expr_shift_sign ('=');
4200 return;
4201 }
4202 }
4203
4204 /* Unary sign */
4205 if ((TOKEN (-1) == '+' || TOKEN (-1) == '-') &&
4206 TOKEN (-2) != 'x') {
4207 if (TOKEN (-1) == '-') {
4208 value = cb_build_binary_op (cb_zero, '-', value);
4209 }
4210 expr_index -= 1;
4211 }
4212 break;
4213
4214 case '(':
4215 /* 'x' op '(' --> '(' 'x' op */
4216 switch (TOKEN (-1)) {
4217 case '=':
4218 case '~':
4219 case '<':
4220 case '>':
4221 case '[':
4222 case ']':
4223 expr_op = TOKEN (-1);
4224 if (TOKEN (-2) == 'x') {
4225 expr_lh = VALUE (-2);
4226 }
4227 break;
4228 default:
4229 break;
4230 }
4231 break;
4232
4233 case ')':
4234 /* Enclosed by parentheses */
4235 (void)expr_reduce (token);
4236 if (VALUE (-1)
4237 && CB_BINARY_OP_P (VALUE (-1))
4238 && binary_op_is_relational (CB_BINARY_OP (VALUE (-1)))) {
4239 /*
4240 If a relation is surrounded in parentheses, it cannot
4241 be the start of an abbreviated condition.
4242 */
4243 expr_lh = NULL;
4244 }
4245 if (TOKEN (-2) == '(') {
4246 if (VALUE (-1)) {
4247 value = CB_BUILD_PARENTHESES (VALUE (-1));
4248 } else {
4249 value = NULL;
4250 }
4251 expr_index -= 2;
4252 cb_expr_shift ('x', value);
4253 return;
4254 }
4255 break;
4256
4257 default:
4258 /* '<' '|' '=' --> '[' */
4259 /* '>' '|' '=' --> ']' */
4260 if (token == '=' && TOKEN (-1) == '|' &&
4261 (TOKEN (-2) == '<' || TOKEN (-2) == '>')) {
4262 token = (TOKEN (-2) == '<') ? '[' : ']';
4263 expr_index -= 2;
4264 }
4265
4266 /* '!' '=' --> '~', etc. */
4267 if (TOKEN (-1) == '!') {
4268 switch (token) {
4269 case '=':
4270 token = '~';
4271 expr_index--;
4272 break;
4273 case '~':
4274 token = '=';
4275 expr_index--;
4276 break;
4277 case '<':
4278 token = ']';
4279 expr_index--;
4280 break;
4281 case '>':
4282 token = '[';
4283 expr_index--;
4284 break;
4285 case '[':
4286 token = '>';
4287 expr_index--;
4288 break;
4289 case ']':
4290 token = '<';
4291 expr_index--;
4292 break;
4293 default:
4294 break;
4295 }
4296 }
4297 break;
4298 }
4299
4300 /* Reduce */
4301 /* Catch invalid condition */
4302 if (expr_reduce (token) > 0) {
4303 return;
4304 }
4305
4306 /* Allocate sufficient stack memory */
4307 if (expr_index >= expr_stack_size) {
4308 while (expr_stack_size <= expr_index) {
4309 expr_stack_size *= 2;
4310 }
4311 expr_stack = cobc_main_realloc (expr_stack, sizeof (struct expr_node) * expr_stack_size);
4312 }
4313
4314 /* Put on the stack */
4315 TOKEN (0) = token;
4316 VALUE (0) = value;
4317 expr_index++;
4318 }
4319
4320 static void
4321 expr_expand (cb_tree *x)
4322 {
4323 struct cb_binary_op *p;
4324
4325 start:
4326 /* Remove parentheses */
4327 if (CB_BINARY_OP_P (*x)) {
4328 p = CB_BINARY_OP (*x);
4329 if (p->op == '@') {
4330 *x = p->x;
4331 goto start;
4332 }
4333 expr_expand (&p->x);
4334 if (p->y) {
4335 expr_expand (&p->y);
4336 }
4337 }
4338 }
4339
4340 static cb_tree
4341 cb_expr_finish (void)
4342 {
4343 /* Reduce all */
4344 (void)expr_reduce (0);
4345
4346 if (!expr_stack[3].value) {
4347 /* TODO: Add test case for this to syn_misc.at invalid expression */
4348 cb_error (_("invalid expression"));
4349 return cb_error_node;
4350 }
4351
4352 expr_stack[3].value->source_file = cb_source_file;
4353 expr_stack[3].value->source_line = cb_exp_line;
4354
4355 if (expr_index != 4) {
4356 /* TODO: Add test case for this to syn_misc.at invalid expression */
4357 cb_error_x (expr_stack[3].value, _("invalid expression"));
4358 return cb_error_node;
4359 }
4360
4361 expr_expand (&expr_stack[3].value);
4362 if (expr_stack[3].token != 'x') {
4363 /* TODO: Add test case for this to syn_misc.at invalid expression */
4364 cb_error_x (expr_stack[3].value, _("invalid expression"));
4365 return cb_error_node;
4366 }
4367
4368 return expr_stack[3].value;
4369 }
4370
4371 cb_tree
4372 cb_build_expr (cb_tree list)
4373 {
4374 cb_tree l, v;
4375 struct cb_field *f;
4376 int op, has_rel, has_con, has_var, bad_cond;
4377
4378 cb_expr_init ();
4379
4380 /* Checkme: maybe add validate_list(l) here */
4381
4382 bad_cond = has_rel = has_con = has_var = 0;
4383 for (l = list; l; l = CB_CHAIN (l)) {
4384 op = CB_PURPOSE_INT (l);
4385 switch (op) {
4386 case '9':
4387 /* NUMERIC */
4388 cb_expr_shift_class ("cob_is_numeric");
4389 has_rel = 1;
4390 break;
4391 case 'A':
4392 /* ALPHABETIC */
4393 cb_expr_shift_class ("cob_is_alpha");
4394 has_rel = 1;
4395 break;
4396 case 'L':
4397 /* ALPHABETIC_LOWER */
4398 cb_expr_shift_class ("cob_is_lower");
4399 has_rel = 1;
4400 break;
4401 case 'U':
4402 /* ALPHABETIC_UPPER */
4403 cb_expr_shift_class ("cob_is_upper");
4404 has_rel = 1;
4405 break;
4406 case 'P':
4407 /* POSITIVE */
4408 cb_expr_shift_sign ('>');
4409 has_rel = 1;
4410 break;
4411 case 'N':
4412 /* NEGATIVE */
4413 cb_expr_shift_sign ('<');
4414 has_rel = 1;
4415 break;
4416 case 'O':
4417 /* OMITTED */
4418 if (current_statement) {
4419 current_statement->null_check = NULL;
4420 }
4421 cb_expr_shift_class ("cob_is_omitted");
4422 has_rel = 1;
4423 break;
4424 case 'C':
4425 /* CLASS */
4426 cb_expr_shift_class (CB_CLASS_NAME (cb_ref (CB_VALUE (l)))->cname);
4427 has_rel = 1;
4428 break;
4429 default:
4430 v = CB_VALUE (l);
4431 if (op == 'x') {
4432 has_var = 1;
4433 if (CB_TREE_TAG (v) == CB_TAG_BINARY_OP) {
4434 has_rel = 1;
4435 } else
4436 if (CB_TREE_TAG (v) == CB_TAG_FUNCALL) {
4437 has_rel = 1;
4438 } else
4439 if (CB_REF_OR_FIELD_P (v)) {
4440 f = CB_FIELD_PTR (v);
4441 if (f->level == 88) {
4442 has_rel = 1;
4443 } else
4444 if (f->storage == CB_STORAGE_CONSTANT) {
4445 has_rel = 1;
4446 }
4447 }
4448 } else
4449 if (op == '|'
4450 || op == '&') {
4451 has_con = 1;
4452 if (has_var && !has_rel) {
4453 bad_cond = 1;
4454 }
4455 } else
4456 if (op == '>'
4457 || op == '<'
4458 || op == '='
4459 || op == '~'
4460 || op == '['
4461 || op == ']') {
4462 has_rel = 1;
4463 } else
4464 if (op == '!') {
4465 has_rel = 1;
4466 }
4467 /* Warning for complex expressions without explicit parentheses
4468 (i.e., "a OR b AND c" or "a AND b OR c") */
4469 if (expr_index > 3
4470 && (op == '|' || op == '&')) {
4471 /* hack to use exp_line instead of source_line */
4472 cb_error_node->source_line = cb_exp_line;
4473 if (op == '|' && expr_stack[expr_index-2].token == '&') {
4474 cb_warning_x (cb_warn_parentheses, cb_error_node,
4475 _("suggest parentheses around %s within %s"), "AND", "OR");
4476 } else
4477 if (op == '&' && expr_stack[expr_index-2].token == '|') {
4478 cb_warning_x (cb_warn_parentheses, cb_error_node,
4479 _("suggest parentheses around %s within %s"), "OR", "AND");
4480 }
4481 cb_error_node->source_line = 0; /* undo hack */
4482 }
4483 cb_expr_shift (op, v);
4484 break;
4485 }
4486 }
4487 if (bad_cond) {
4488 cb_error_x (list, _("invalid conditional expression"));
4489 return cb_any;
4490 }
4491
4492 return cb_expr_finish ();
4493 }
4494
4495 const char *
4496 explain_operator (const int op)
4497 {
4498 switch (op)
4499 {
4500 case '>':
4501 return "GREATER THAN";
4502 case '<':
4503 return "LESS THAN";
4504 case ']':
4505 return "GREATER OR EQUAL";
4506 case '[':
4507 return "LESS OR EQUAL";
4508 case '=':
4509 return "EQUALS";
4510 case '~':
4511 return "NOT EQUAL";
4512 case '!':
4513 return "NOT";
4514 case '&':
4515 return "AND";
4516 case '|':
4517 return "OR";
4518 default:
4519 return NULL;
4520 }
4521 }
4522
4523 const char *
4524 enum_explain_storage (const enum cb_storage storage)
4525 {
4526 switch (storage) {
4527 case CB_STORAGE_CONSTANT:
4528 return "Constants";
4529 case CB_STORAGE_FILE:
4530 return "FILE SECTION";
4531 case CB_STORAGE_WORKING:
4532 return "WORKING-STORAGE SECTION";
4533 case CB_STORAGE_LOCAL:
4534 return "LOCAL-STORAGE SECTION";
4535 case CB_STORAGE_LINKAGE:
4536 return "LINKAGE SECTION";
4537 case CB_STORAGE_SCREEN:
4538 return "SCREEN SECTION";
4539 case CB_STORAGE_REPORT:
4540 return "REPORT SECTION";
4541 case CB_STORAGE_COMMUNICATION:
4542 return "COMMUNICATION SECTION";
4543 default:
4544 break;
4545 }
4546 return "UNKNOWN";
4547 }
4548
4549 /* Numerical operation */
4550
4551 static cb_tree
4552 build_store_option (cb_tree x, cb_tree round_opt)
4553 {
4554 struct cb_field *f;
4555 int opt;
4556 enum cb_usage usage;
4557
4558 f = CB_FIELD_PTR (x);
4559 usage = f->usage;
4560 #if 0 /* RXWRXW - FP */
4561 if (usage == CB_USAGE_DOUBLE || usage == CB_USAGE_FLOAT) {
4562 /* Rounding on FP is useless */
4563 opt = 0;
4564 } else {
4565 #endif
4566 opt = CB_INTEGER (round_opt)->val;
4567 #if 0 /* RXWRXW - FP */
4568 }
4569 #endif
4570
4571 if (usage == CB_USAGE_COMP_5
4572 || usage == CB_USAGE_COMP_X
4573 || usage == CB_USAGE_COMP_N) {
4574 /* Do not check NOT ERROR case, so that we optimize */
4575 if (current_statement->ex_handler) {
4576 opt |= COB_STORE_KEEP_ON_OVERFLOW;
4577 }
4578 } else if (current_statement->handler_type != NO_HANDLER) {
4579 /* There is a [NOT] ERROR/OVERFLOW/EXCEPTION - Set in parser */
4580 opt |= COB_STORE_KEEP_ON_OVERFLOW;
4581 } else if (usage == CB_USAGE_BINARY && cb_binary_truncate) {
4582 /* Truncate binary field to digits in picture */
4583 opt |= COB_STORE_TRUNC_ON_OVERFLOW;
4584 }
4585
4586 return cb_int (opt);
4587 }
4588
4589 static cb_tree
4590 decimal_alloc (void)
4591 {
4592 cb_tree x;
4593
4594 x = cb_build_decimal (current_program->decimal_index);
4595 current_program->decimal_index++;
4596 /* LCOV_EXCL_START */
4597 if (current_program->decimal_index >= COB_MAX_DEC_STRUCT) {
4598 cobc_err_msg (_("internal decimal structure size exceeded: %d"),
4599 COB_MAX_DEC_STRUCT);
4600 if (strcmp(current_statement->name, "COMPUTE") == 0) {
4601 cobc_err_msg (_("Try to minimize the number of parentheses "
4602 "or split into multiple computations."));
4603 }
4604 COBC_ABORT ();
4605 }
4606 /* LCOV_EXCL_STOP */
4607 if (current_program->decimal_index > current_program->decimal_index_max) {
4608 current_program->decimal_index_max = current_program->decimal_index;
4609 }
4610 return x;
4611 }
4612
4613 static void
4614 decimal_free (void)
4615 {
4616 current_program->decimal_index--;
4617 }
4618 static void
4619 push_expr_dec (int dec)
4620 {
4621 if (expr_nest < MAX_NESTED_EXPR) {
4622 expr_decp[expr_nest++] = dec;
4623 } else {
4624 cb_warning (COBC_WARN_FILLER,
4625 _("more than %d nested expressions"), MAX_NESTED_EXPR);
4626 }
4627 }
4628
4629 static void
4630 decimal_align (void)
4631 {
4632 cb_tree expr_dec = NULL; /* Int value for decimal_align */
4633
4634 if (expr_dec_align >= 0
4635 && expr_x != NULL) {
4636 switch(expr_dec_align) {
4637 case 0:
4638 expr_dec = cb_int0;
4639 break;
4640 case 1:
4641 expr_dec = cb_int1;
4642 break;
4643 case 2:
4644 expr_dec = cb_int2;
4645 break;
4646 case 3:
4647 expr_dec = cb_int3;
4648 break;
4649 case 4:
4650 expr_dec = cb_int4;
4651 break;
4652 case 5:
4653 expr_dec = cb_int5;
4654 break;
4655 case 6:
4656 expr_dec = cb_int6;
4657 break;
4658 default:
4659 expr_dec = cb_int (expr_dec_align);
4660 break;
4661 }
4662 dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_align", expr_x, expr_dec));
4663 if (expr_line != cb_source_line) {
4664 expr_line = cb_source_line; /* only warn once per line */
4665 cb_warning_x (cb_warn_arithmetic_osvs, CB_TREE (current_statement),
4666 _("precision of result may change with arithmetic-osvs"));
4667 }
4668 expr_dec_align = -1;
4669 expr_x = NULL;
4670 }
4671 }
4672
4673 static void
4674 decimal_compute (const int op, cb_tree x, cb_tree y)
4675 {
4676 const char *func;
4677 int decp, d;
4678
4679 /* skip if the actual statement can't be generated any more
4680 to prevent multiple errors here */
4681 if (error_statement == current_statement) {
4682 return;
4683 }
4684
4685 if (!current_program->flag_decimal_comp) {
4686 struct cb_program* prog;
4687 for (prog = current_program; prog && !prog->flag_decimal_comp; prog = prog->next_program) {
4688 prog->flag_decimal_comp = 1;
4689 }
4690 }
4691
4692 if (cb_arithmetic_osvs) {
4693 if (expr_dec_align >= 0
4694 && expr_x != NULL
4695 && expr_x != x) {
4696 decimal_align ();
4697 }
4698 decp = expr_dmax;
4699 } else {
4700 decp = -1; /* fix missing initialization warning, not actually used */
4701 }
4702 switch (op) {
4703 case '+':
4704 func = "cob_decimal_add";
4705 break;
4706 case '-':
4707 func = "cob_decimal_sub";
4708 break;
4709 case '*':
4710 func = "cob_decimal_mul";
4711 break;
4712 case '/':
4713 func = "cob_decimal_div";
4714 break;
4715 case '^':
4716 func = "cob_decimal_pow";
4717 break;
4718 default:
4719 func = explain_operator (op);
4720 /* LCOV_EXCL_START */
4721 if (!func) {
4722 cobc_err_msg (_("unexpected operation: %c (%d)"), (char)op, op);
4723 COBC_ABORT ();
4724 }
4725 /* LCOV_EXCL_STOP */
4726 error_statement = current_statement;
4727 cb_error_x (CB_TREE(current_statement), _("%s operator may be misplaced"), func);
4728 return;
4729 }
4730 if (cb_arithmetic_osvs
4731 && expr_nest > 1) {
4732 expr_nest--;
4733 switch (op) {
4734 case '+':
4735 if (expr_decp [expr_nest] > expr_decp [expr_nest-1]) {
4736 expr_decp [expr_nest-1] = expr_decp [expr_nest];
4737 }
4738 break;
4739 case '-':
4740 if (expr_decp [expr_nest] > expr_decp [expr_nest-1]) {
4741 expr_decp [expr_nest-1] = expr_decp [expr_nest];
4742 }
4743 break;
4744 case '*':
4745 expr_decp [expr_nest-1] += expr_decp [expr_nest];
4746 break;
4747 case '/':
4748 d = expr_decp [expr_nest-1] - expr_decp [expr_nest];
4749 if (d > expr_dmax) {
4750 expr_decp [expr_nest-1] = d;
4751 } else {
4752 expr_decp [expr_nest-1] = expr_dmax;
4753 }
4754 break;
4755 case '^':
4756 if (expr_decp [expr_nest-1] - expr_decp [expr_nest]
4757 < expr_decp [expr_nest-1]) {
4758 expr_decp [expr_nest-1] = expr_decp [expr_nest-1] - expr_decp [expr_nest];
4759 }
4760 break;
4761 }
4762 decp = expr_decp [expr_nest-1];
4763 }
4764
4765 dpush (CB_BUILD_FUNCALL_2 (func, x, y));
4766
4767 /* Save for later decimal_align */
4768 if (cb_arithmetic_osvs) {
4769 expr_dec_align = decp;
4770 } else {
4771 expr_dec_align = -1;
4772 }
4773 expr_x = x;
4774 }
4775
4776 /**
4777 * expand tree x to the previously allocated decimal tree d
4778 */
4779 static void
4780 decimal_expand (cb_tree d, cb_tree x)
4781 {
4782 struct cb_literal *l;
4783 struct cb_field *f;
4784 struct cb_binary_op *p;
4785 cb_tree t;
4786
4787 /* skip if the actual statement can't be generated any more
4788 to prevent multiple errors here */
4789 if (error_statement == current_statement) {
4790 return;
4791 }
4792 switch (CB_TREE_TAG (x)) {
4793 case CB_TAG_CONST:
4794 /* LCOV_EXCL_START */
4795 if (x != cb_zero) {
4796 cobc_err_msg (_("unexpected constant expansion"));
4797 COBC_ABORT ();
4798 }
4799 /* LCOV_EXCL_STOP */
4800 dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_llint", d,
4801 cb_int0));
4802 break;
4803 case CB_TAG_LITERAL:
4804 /* Set d, N */
4805 decimal_align ();
4806 l = CB_LITERAL (x);
4807 if (l->size < 19 && l->scale == 0) {
4808 dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_llint", d,
4809 cb_build_cast_llint (x)));
4810 } else {
4811 dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_field", d, x));
4812 push_expr_dec (l->scale);
4813 }
4814 break;
4815 case CB_TAG_REFERENCE:
4816 /* Set d, X */
4817 f = CB_FIELD_PTR (x);
4818 /* Check numeric */
4819 if (cb_flag_correct_numeric && f->usage == CB_USAGE_DISPLAY) {
4820 cb_emit (CB_BUILD_FUNCALL_1 ("cob_correct_numeric", x));
4821 }
4822 if (CB_EXCEPTION_ENABLE (COB_EC_DATA_INCOMPATIBLE)) {
4823 if (f->usage == CB_USAGE_DISPLAY ||
4824 f->usage == CB_USAGE_PACKED ||
4825 f->usage == CB_USAGE_COMP_6) {
4826 dpush (CB_BUILD_FUNCALL_2 ("cob_check_numeric",
4827 x, CB_BUILD_STRING0 (f->name)));
4828 }
4829 }
4830 decimal_align ();
4831
4832 if ( (f->usage == CB_USAGE_BINARY
4833 || f->usage == CB_USAGE_COMP_5
4834 || f->usage == CB_USAGE_INDEX
4835 || f->usage == CB_USAGE_HNDL
4836 || f->usage == CB_USAGE_HNDL_WINDOW
4837 || f->usage == CB_USAGE_HNDL_SUBWINDOW
4838 || f->usage == CB_USAGE_HNDL_FONT
4839 || f->usage == CB_USAGE_HNDL_THREAD
4840 || f->usage == CB_USAGE_HNDL_MENU
4841 || f->usage == CB_USAGE_HNDL_VARIANT
4842 || f->usage == CB_USAGE_HNDL_LM
4843 || f->usage == CB_USAGE_COMP_X
4844 || f->usage == CB_USAGE_COMP_N)
4845 && !f->pic->scale
4846 && (f->size == 1 || f->size == 2 || f->size == 4 ||
4847 f->size == 8)) {
4848 if (f->pic->have_sign) {
4849 dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_llint",
4850 d, cb_build_cast_llint (x)));
4851 } else {
4852 dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_ullint",
4853 d, cb_build_cast_llint (x)));
4854 }
4855 } else {
4856 dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_field", d, x));
4857 push_expr_dec (f->pic->scale);
4858 }
4859 break;
4860 case CB_TAG_BINARY_OP:
4861 /* Set d, X
4862 * Set t, Y
4863 * OP d, t */
4864 p = CB_BINARY_OP (x);
4865 decimal_expand (d, p->x);
4866
4867 if (CB_TREE_TAG (p->y) == CB_TAG_LITERAL
4868 && CB_TREE_CATEGORY (p->y) == CB_CATEGORY_NUMERIC) {
4869 t = cb_build_decimal_literal (cb_lookup_literal(p->y,1));
4870 decimal_compute (p->op, d, t);
4871 } else {
4872 t = decimal_alloc ();
4873 decimal_expand (t, p->y);
4874 decimal_compute (p->op, d, t);
4875 decimal_free ();
4876 }
4877 break;
4878 case CB_TAG_INTRINSIC:
4879 decimal_align ();
4880 dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_set_field", d, x));
4881 push_expr_dec (0);
4882 break;
4883 /* LCOV_EXCL_START */
4884 default:
4885 cobc_err_msg (_("unexpected tree tag: %d"), (int)CB_TREE_TAG (x));
4886 COBC_ABORT ();
4887 /* LCOV_EXCL_STOP */
4888 }
4889 }
4890
4891 static void
4892 decimal_assign (cb_tree x, cb_tree d, cb_tree round_opt)
4893 {
4894 dpush (CB_BUILD_FUNCALL_3 ("cob_decimal_get_field", d, x,
4895 build_store_option (x, round_opt)));
4896 }
4897
4898 static cb_tree
4899 cb_build_mul (cb_tree v, cb_tree n, cb_tree round_opt)
4900 {
4901 cb_tree opt;
4902 struct cb_field *f;
4903
4904 if (CB_INDEX_OR_HANDLE_P (v)) {
4905 return cb_build_move (cb_build_binary_op (v, '*', n), v);
4906 }
4907
4908 if (CB_REF_OR_FIELD_P (v)) {
4909 f = CB_FIELD_PTR (v);
4910 f->count++;
4911 }
4912 if (CB_REF_OR_FIELD_P (n)) {
4913 f = CB_FIELD_PTR (n);
4914 f->count++;
4915 }
4916 opt = build_store_option (v, round_opt);
4917 return CB_BUILD_FUNCALL_3 ("cob_mul", v, n, opt);
4918 }
4919
4920 static cb_tree
4921 cb_build_div (cb_tree v, cb_tree n, cb_tree round_opt)
4922 {
4923 cb_tree opt;
4924 struct cb_field *f;
4925
4926 if (CB_INDEX_OR_HANDLE_P (v)) {
4927 return cb_build_move (cb_build_binary_op (v, '/', n), v);
4928 }
4929
4930 if (CB_REF_OR_FIELD_P (v)) {
4931 f = CB_FIELD_PTR (v);
4932 f->count++;
4933 }
4934 if (CB_REF_OR_FIELD_P (n)) {
4935 f = CB_FIELD_PTR (n);
4936 f->count++;
4937 }
4938 opt = build_store_option (v, round_opt);
4939 return CB_BUILD_FUNCALL_3 ("cob_div", v, n, opt);
4940 }
4941
4942 static cb_tree
4943 build_decimal_assign (cb_tree vars, const int op, cb_tree val)
4944 {
4945 struct cb_field *f;
4946 cb_tree l;
4947 cb_tree t;
4948 cb_tree s1;
4949 cb_tree s2;
4950 cb_tree d;
4951
4952 /* note: vars validated by caller: cb_emit_arithmetic */
4953 if (cb_arithmetic_osvs) {
4954 /* ARITHMETIC-OSVS: Determine largest scale used in result field */
4955 expr_dec_align = -1;
4956 expr_rslt = CB_VALUE(vars);
4957 for (l = vars; l; l = CB_CHAIN (l)) {
4958 if (CB_FIELD_P (cb_ref (CB_VALUE(l)))) {
4959 f = CB_FIELD_PTR (CB_VALUE(l));
4960 if(f->pic->scale > expr_dmax) {
4961 expr_dmax = f->pic->scale;
4962 }
4963 }
4964 }
4965 cb_walk_cond (val);
4966 } else {
4967 expr_dmax = -1;
4968 expr_dec_align = -1;
4969 }
4970 expr_nest = 0;
4971
4972 d = decimal_alloc ();
4973
4974 /* Set d, VAL */
4975 decimal_expand (d, val);
4976
4977 s1 = NULL;
4978 if (op == 0) {
4979 for (l = vars; l; l = CB_CHAIN (l)) {
4980 /* Set VAR, d */
4981 decimal_assign (CB_VALUE (l), d, CB_PURPOSE (l));
4982 s2 = cb_list_reverse (decimal_stack);
4983 if (!s1) {
4984 s1 = s2;
4985 } else {
4986 s1 = cb_list_append (s1, s2);
4987 }
4988 decimal_stack = NULL;
4989 }
4990 } else {
4991 t = decimal_alloc ();
4992 for (l = vars; l; l = CB_CHAIN (l)) {
4993 /* Set t, VAR
4994 * OP t, d
4995 * set VAR, t
4996 */
4997 decimal_expand (t, CB_VALUE (l));
4998 decimal_compute (op, t, d);
4999 decimal_assign (CB_VALUE (l), t, CB_PURPOSE (l));
5000 s2 = cb_list_reverse (decimal_stack);
5001 if (!s1) {
5002 s1 = s2;
5003 } else {
5004 s1 = cb_list_append (s1, s2);
5005 }
5006 decimal_stack = NULL;
5007 }
5008 decimal_free ();
5009 }
5010
5011 decimal_free ();
5012 expr_dmax = -1;
5013 expr_dec_align = -1;
5014 expr_nest = 0;
5015
5016 return s1;
5017 }
5018
5019 void
5020 cb_set_dmax (int scale)
5021 {
5022 if (cb_arithmetic_osvs
5023 && scale > expr_dmax) {
5024 expr_dmax = scale;
5025 }
5026 }
5027
5028 void
5029 cb_emit_arithmetic (cb_tree vars, const int op, cb_tree val)
5030 {
5031 cb_tree l;
5032 cb_tree x;
5033
5034 x = cb_check_numeric_value (val);
5035
5036 if (cb_validate_one (x)
5037 || cb_validate_list (vars)) {
5038 return;
5039 }
5040
5041
5042 if (op) {
5043 if (cb_list_map(cb_check_numeric_name, vars)) {
5044 return;
5045 }
5046 } else {
5047 if (cb_list_map (cb_check_numeric_edited_name, vars)) {
5048 return;
5049 }
5050 }
5051
5052 if (!CB_BINARY_OP_P (x)) {
5053 if (op == '+' || op == '-' || op == '*' || op == '/') {
5054 cb_check_data_incompat (x);
5055 for (l = vars; l; l = CB_CHAIN (l)) {
5056 cb_check_data_incompat (CB_VALUE (l));
5057 switch (op) {
5058 case '+':
5059 CB_VALUE (l) = cb_build_add (CB_VALUE (l), x, CB_PURPOSE (l));
5060 break;
5061 case '-':
5062 CB_VALUE (l) = cb_build_sub (CB_VALUE (l), x, CB_PURPOSE (l));
5063 break;
5064 case '*':
5065 CB_VALUE (l) = cb_build_mul (CB_VALUE (l), x, CB_PURPOSE (l));
5066 break;
5067 case '/':
5068 CB_VALUE (l) = cb_build_div (CB_VALUE (l), x, CB_PURPOSE (l));
5069 break;
5070 }
5071 }
5072 cb_emit_list (vars);
5073 return;
5074 }
5075 }
5076 if (x == cb_error_node) {
5077 return;
5078 }
5079
5080 cb_emit_list (build_decimal_assign (vars, op, x));
5081 }
5082
5083 /* Condition */
5084
5085 static cb_tree
5086 build_cond_88 (cb_tree x)
5087 {
5088 struct cb_field *f;
5089 const char *real_statement; /* bad hack... */
5090
5091 cb_tree l;
5092 cb_tree t;
5093 cb_tree c1;
5094 cb_tree c2;
5095
5096 f = CB_FIELD_PTR (x);
5097 /* Refer to parents data storage */
5098 if (!f->parent) {
5099 /* Field is invalid */
5100 return cb_error_node;
5101 }
5102 x = cb_build_field_reference (f->parent, x);
5103 f->parent->count++;
5104 c1 = NULL;
5105
5106 /* Build condition */
5107 for (l = f->values; l; l = CB_CHAIN (l)) {
5108 t = CB_VALUE (l);
5109 if (CB_PAIR_P (t)) {
5110 /* VALUE THRU VALUE */
5111 real_statement = current_statement->name;
5112 current_statement->name = "VALUE THRU";
5113 c2 = cb_build_binary_op (cb_build_binary_op (x, ']', CB_PAIR_X (t)),
5114 '&', cb_build_binary_op (x, '[', CB_PAIR_Y (t)));
5115 current_statement->name = real_statement;
5116 } else {
5117 /* VALUE */
5118 c2 = cb_build_binary_op (x, '=', t);
5119 }
5120 if (c1 == NULL) {
5121 c1 = c2;
5122 } else {
5123 c1 = cb_build_binary_op (c1, '|', c2);
5124 }
5125 }
5126
5127 return c1;
5128 }
5129
5130 static cb_tree
5131 cb_build_optim_cond (struct cb_binary_op *p)
5132 {
5133 struct cb_field *f;
5134 const char *s;
5135 size_t n;
5136
5137 #if 0 /* RXWRXW - US */
5138 struct cb_field *fy;
5139 if (CB_REF_OR_FIELD_P (p->y)) {
5140 fy = CB_FIELD_PTR (p->y);
5141 if (!fy->pic->have_sign
5142 && (fy->usage == CB_USAGE_BINARY
5143 || fy->usage == CB_USAGE_COMP_5
5144 || fy->usage == CB_USAGE_COMP_X
5145 || fy->usage == CB_USAGE_COMP_N)) {
5146 return CB_BUILD_FUNCALL_2 ("cob_cmp_uint", p->x,
5147 cb_build_cast_int (p->y));
5148 }
5149 }
5150 #endif
5151
5152 if (!CB_REF_OR_FIELD_P (p->x)) {
5153 return CB_BUILD_FUNCALL_2 ("cob_cmp_llint", p->x,
5154 cb_build_cast_llint (p->y));
5155 }
5156
5157 f = CB_FIELD_PTR (p->x);
5158 #if 0 /* CHECKME, if needed */
5159 if (cb_listing_xref) {
5160 cobc_xref_link (&f->xref, current_statement->common.source_line);
5161 }
5162 #endif
5163 #if 0 /* RXWRXW - SI */
5164 if (f->index_type) {
5165 return CB_BUILD_FUNCALL_2 ("cob_cmp_special",
5166 cb_build_cast_int (p->x),
5167 cb_build_cast_int (p->y));
5168 }
5169 #endif
5170 if (f->pic->scale || f->flag_any_numeric) {
5171 return CB_BUILD_FUNCALL_2 ("cob_cmp_llint", p->x,
5172 cb_build_cast_llint (p->y));
5173 }
5174 if (f->usage == CB_USAGE_PACKED) {
5175 if (f->pic->digits < 19) {
5176 optimize_defs[COB_CMP_PACKED_INT] = 1;
5177 return CB_BUILD_FUNCALL_2 ("cob_cmp_packed_int",
5178 p->x,
5179 cb_build_cast_llint (p->y));
5180 } else {
5181 return CB_BUILD_FUNCALL_2 ("cob_cmp_packed",
5182 p->x,
5183 cb_build_cast_llint (p->y));
5184 }
5185 }
5186 if (f->usage == CB_USAGE_COMP_6) {
5187 return CB_BUILD_FUNCALL_2 ("cob_cmp_packed",
5188 p->x,
5189 cb_build_cast_llint (p->y));
5190 }
5191 if (f->usage == CB_USAGE_DISPLAY &&
5192 !f->flag_sign_leading && !f->flag_sign_separate) {
5193 if (cb_fits_long_long (p->x)) {
5194 return CB_BUILD_FUNCALL_4 ("cob_cmp_numdisp",
5195 CB_BUILD_CAST_ADDRESS (p->x),
5196 cb_int (f->size),
5197 cb_build_cast_llint (p->y),
5198 cb_int (f->pic->have_sign ? 1 : 0));
5199 }
5200 return CB_BUILD_FUNCALL_2 ("cob_cmp_llint", p->x,
5201 cb_build_cast_llint (p->y));
5202 }
5203 if (f->usage == CB_USAGE_BINARY
5204 || f->usage == CB_USAGE_COMP_5
5205 || f->usage == CB_USAGE_INDEX
5206 || f->usage == CB_USAGE_HNDL
5207 || f->usage == CB_USAGE_HNDL_WINDOW
5208 || f->usage == CB_USAGE_HNDL_SUBWINDOW
5209 || f->usage == CB_USAGE_HNDL_FONT
5210 || f->usage == CB_USAGE_HNDL_THREAD
5211 || f->usage == CB_USAGE_HNDL_MENU
5212 || f->usage == CB_USAGE_HNDL_VARIANT
5213 || f->usage == CB_USAGE_HNDL_LM
5214 || f->usage == CB_USAGE_COMP_X
5215 || f->usage == CB_USAGE_COMP_N) {
5216 n = ((size_t)f->size - 1)
5217 + (8 * (f->pic->have_sign ? 1 : 0))
5218 + (16 * (f->flag_binary_swap ? 1 : 0));
5219 #if defined(COB_NON_ALIGNED) && !defined(_MSC_VER) && defined(COB_ALLOW_UNALIGNED)
5220 switch (f->size) {
5221 case 2:
5222 #ifdef COB_SHORT_BORK
5223 optimize_defs[bin_compare_funcs[n].optim_val] = 1;
5224 s = bin_compare_funcs[n].optim_name;
5225 break;
5226 #endif
5227 case 4:
5228 case 8:
5229 if (f->storage != CB_STORAGE_LINKAGE &&
5230 f->indexes == 0 && (f->offset % f->size) == 0) {
5231 optimize_defs[align_bin_compare_funcs[n].optim_val] = 1;
5232 s = align_bin_compare_funcs[n].optim_name;
5233 } else {
5234 optimize_defs[bin_compare_funcs[n].optim_val] = 1;
5235 s = bin_compare_funcs[n].optim_name;
5236 }
5237 break;
5238 default:
5239 optimize_defs[bin_compare_funcs[n].optim_val] = 1;
5240 s = bin_compare_funcs[n].optim_name;
5241 break;
5242 }
5243 #else
5244 optimize_defs[bin_compare_funcs[n].optim_val] = 1;
5245 s = bin_compare_funcs[n].optim_name;
5246 #endif
5247 if (s) {
5248 return CB_BUILD_FUNCALL_2 (s,
5249 CB_BUILD_CAST_ADDRESS (p->x),
5250 cb_build_cast_llint (p->y));
5251 }
5252 }
5253 return CB_BUILD_FUNCALL_2 ("cob_cmp_llint", p->x,
5254 cb_build_cast_llint (p->y));
5255 }
5256
5257 static int
5258 cb_check_num_cond (cb_tree x, cb_tree y)
5259 {
5260 struct cb_field *fx;
5261 struct cb_field *fy;
5262
5263 if (!CB_REF_OR_FIELD_P (x)) {
5264 return 0;
5265 }
5266 if (!CB_REF_OR_FIELD_P (y)) {
5267 return 0;
5268 }
5269 if (CB_TREE_CATEGORY (x) != CB_CATEGORY_NUMERIC) {
5270 return 0;
5271 }
5272 if (CB_TREE_CATEGORY (y) != CB_CATEGORY_NUMERIC) {
5273 return 0;
5274 }
5275 if (CB_TREE_CLASS (x) != CB_CLASS_NUMERIC) {
5276 return 0;
5277 }
5278 if (CB_TREE_CLASS (y) != CB_CLASS_NUMERIC) {
5279 return 0;
5280 }
5281 fx = CB_FIELD_PTR (x);
5282 fy = CB_FIELD_PTR (y);
5283 if (fx->usage != CB_USAGE_DISPLAY) {
5284 return 0;
5285 }
5286 if (fy->usage != CB_USAGE_DISPLAY) {
5287 return 0;
5288 }
5289 if (fx->pic->have_sign || fy->pic->have_sign) {
5290 return 0;
5291 }
5292 if (fx->size != fy->size) {
5293 return 0;
5294 }
5295 if (fx->pic->scale != fy->pic->scale) {
5296 return 0;
5297 }
5298 return 1;
5299 }
5300
5301 static int
5302 cb_check_alpha_cond (cb_tree x)
5303 {
5304 if (current_program->alphabet_name_list) {
5305 return 0;
5306 }
5307 if (CB_LITERAL_P (x)) {
5308 return 1;
5309 }
5310 if (!CB_REF_OR_FIELD_P (x)) {
5311 return 0;
5312 }
5313 if (CB_TREE_CATEGORY (x) != CB_CATEGORY_ALPHANUMERIC &&
5314 CB_TREE_CATEGORY (x) != CB_CATEGORY_ALPHABETIC) {
5315 return 0;
5316 }
5317 if (cb_field_variable_size (CB_FIELD_PTR (x))) {
5318 return 0;
5319 }
5320 if (cb_field_size (x) == FIELD_SIZE_UNKNOWN) {
5321 return 0;
5322 }
5323 return 1;
5324 }
5325
5326 static void
5327 cb_walk_cond (cb_tree x)
5328 {
5329 struct cb_binary_op *p;
5330 struct cb_field *f;
5331 struct cb_literal *l;
5332
5333 if (x == NULL)
5334 return;
5335
5336 switch (CB_TREE_TAG (x)) {
5337 case CB_TAG_LITERAL:
5338 if (CB_TREE_CATEGORY (x) == CB_CATEGORY_NUMERIC) {
5339 l = CB_LITERAL (x);
5340 if (l->scale > expr_dmax) {
5341 expr_dmax = l->scale;
5342 }
5343 }
5344 break;
5345
5346 case CB_TAG_REFERENCE:
5347 if (!CB_FIELD_P (cb_ref (x))) {
5348 return;
5349 }
5350
5351 f = CB_FIELD_PTR (x);
5352
5353 if (f->level == 88) {
5354 return ;
5355 }
5356 if(f->pic
5357 && f->pic->scale > expr_dmax) {
5358 expr_dmax = f->pic->scale;
5359 }
5360
5361 break;
5362
5363 case CB_TAG_BINARY_OP:
5364 p = CB_BINARY_OP (x);
5365 cb_walk_cond (p->x);
5366 if (p->op != '/') {
5367 cb_walk_cond (p->y);
5368 }
5369 break;
5370
5371 default:
5372 return;
5373 }
5374 }
5375
5376 cb_tree
5377 cb_build_cond (cb_tree x)
5378 {
5379 struct cb_field *f;
5380 struct cb_binary_op *p;
5381 cb_tree d1;
5382 cb_tree d2;
5383 cb_tree ret;
5384 int size1;
5385 int size2;
5386
5387 if (x == cb_error_node) {
5388 return cb_error_node;
5389 }
5390
5391 if (cb_arithmetic_osvs) {
5392 /* ARITHMETIC-OSVS: Determine largest scale used in condition */
5393 if (expr_dmax == -1) {
5394 /* FIXME: this is a hack, x should always be a list! */
5395 if (CB_LIST_P(x)) {
5396 expr_rslt = CB_VALUE(x);
5397 } else {
5398 expr_rslt = x;
5399 }
5400 cb_walk_cond (x);
5401 }
5402 } else {
5403 expr_dmax = -1;
5404 expr_dec_align = -1;
5405 expr_nest = 0;
5406 }
5407
5408 switch (CB_TREE_TAG (x)) {
5409 case CB_TAG_CONST:
5410 if (x != cb_any && x != cb_true && x != cb_false) {
5411 /* TODO: Add test case for this to syn_misc.at invalid expression */
5412 cb_error_x (CB_TREE(current_statement),
5413 _("invalid expression"));
5414 return cb_error_node;
5415 }
5416 return x;
5417 case CB_TAG_FUNCALL:
5418 return x;
5419 case CB_TAG_REFERENCE:
5420 if (!CB_FIELD_P (cb_ref (x))) {
5421 ret = cb_build_cond (cb_ref (x));
5422 cb_copy_source_reference (ret, x);
5423 return ret;
5424 }
5425
5426 f = CB_FIELD_PTR (x);
5427
5428 /* Level 88 condition */
5429 if (f->level == 88) {
5430 /* Build an 88 condition at every occurrence */
5431 /* as it may be subscripted */
5432 ret = cb_build_cond (build_cond_88 (x));
5433 cb_copy_source_reference (ret, x);
5434 return ret;
5435 }
5436
5437 break;
5438 case CB_TAG_BINARY_OP:
5439 p = CB_BINARY_OP (x);
5440 if (!p->x || p->x == cb_error_node) {
5441 return cb_error_node;
5442 }
5443 switch (p->op) {
5444 case '!':
5445 return CB_BUILD_NEGATION (cb_build_cond (p->x));
5446 case '&':
5447 case '|':
5448 if (!p->y || p->y == cb_error_node) {
5449 return cb_error_node;
5450 }
5451 return cb_build_binary_op (cb_build_cond (p->x), p->op, cb_build_cond (p->y));
5452 default:
5453 if (!p->y || p->y == cb_error_node) {
5454 return cb_error_node;
5455 }
5456 if (CB_INDEX_OR_HANDLE_P (p->x)
5457 || CB_INDEX_OR_HANDLE_P (p->y)
5458 || CB_TREE_CLASS (p->x) == CB_CLASS_POINTER
5459 || CB_TREE_CLASS (p->y) == CB_CLASS_POINTER) {
5460 ret = cb_build_binary_op (p->x, '-', p->y);
5461 } else if (CB_BINARY_OP_P (p->x)
5462 || CB_BINARY_OP_P (p->y)) {
5463 /* Decimal comparison */
5464 d1 = decimal_alloc ();
5465 d2 = decimal_alloc ();
5466
5467 decimal_expand (d1, p->x);
5468 decimal_expand (d2, p->y);
5469 dpush (CB_BUILD_FUNCALL_2 ("cob_decimal_cmp", d1, d2));
5470 decimal_free ();
5471 decimal_free ();
5472 ret = cb_list_reverse (decimal_stack);
5473 decimal_stack = NULL;
5474 } else {
5475 /* DEBUG Bypass optimization for PERFORM */
5476 if (current_program->flag_debugging) {
5477 ret = CB_BUILD_FUNCALL_2 ("cob_cmp", p->x, p->y);
5478 break;
5479 }
5480 if (cb_check_num_cond (p->x, p->y)) {
5481 size1 = cb_field_size (p->x);
5482 ret = CB_BUILD_FUNCALL_3 ("memcmp",
5483 CB_BUILD_CAST_ADDRESS (p->x),
5484 CB_BUILD_CAST_ADDRESS (p->y),
5485 cb_int (size1));
5486 break;
5487 }
5488 if (CB_TREE_CLASS (p->x) == CB_CLASS_NUMERIC &&
5489 CB_TREE_CLASS (p->y) == CB_CLASS_NUMERIC &&
5490 cb_fits_long_long (p->y)) {
5491 ret = cb_build_optim_cond (p);
5492 break;
5493 }
5494
5495 /* Field comparison */
5496 if ((CB_REF_OR_FIELD_P (p->x)) &&
5497 (CB_TREE_CATEGORY (p->x) == CB_CATEGORY_ALPHANUMERIC ||
5498 CB_TREE_CATEGORY (p->x) == CB_CATEGORY_ALPHABETIC) &&
5499 cb_field_size (p->x) == 1 &&
5500 !current_program->alphabet_name_list &&
5501 (p->y == cb_space || p->y == cb_low ||
5502 p->y == cb_high || p->y == cb_zero)) {
5503 ret = CB_BUILD_FUNCALL_2 ("$G", p->x, p->y);
5504 break;
5505 }
5506 if (cb_check_alpha_cond (p->x) &&
5507 cb_check_alpha_cond (p->y)) {
5508 size1 = cb_field_size (p->x);
5509 size2 = cb_field_size (p->y);
5510 } else {
5511 size1 = 0;
5512 size2 = 0;
5513 }
5514 if (size1 == 1 && size2 == 1) {
5515 ret = CB_BUILD_FUNCALL_2 ("$G", p->x, p->y);
5516 } else if (size1 != 0 && size1 == size2) {
5517 ret = CB_BUILD_FUNCALL_3 ("memcmp",
5518 CB_BUILD_CAST_ADDRESS (p->x),
5519 CB_BUILD_CAST_ADDRESS (p->y),
5520 cb_int (size1));
5521 } else {
5522 if (CB_TREE_CLASS (p->x) == CB_CLASS_NUMERIC && p->y == cb_zero) {
5523 ret = cb_build_optim_cond (p);
5524 } else {
5525 ret = CB_BUILD_FUNCALL_2 ("cob_cmp", p->x, p->y);
5526 }
5527 }
5528 }
5529 }
5530 ret = cb_build_binary_op (ret, p->op, p->y);
5531 if (ret != cb_true && ret != cb_false) {
5532 cb_copy_source_reference (ret, x);
5533 }
5534 return ret;
5535 default:
5536 break;
5537 }
5538 cb_error_x (x, _("invalid expression"));
5539 return cb_error_node;
5540 }
5541
5542 /* End parsing a 'condition' */
5543 void
5544 cb_end_cond (cb_tree rslt)
5545 {
5546 expr_dmax = -1; /* Reset 'Max scale' */
5547 expr_dec_align = -1;
5548 expr_nest = 0;
5549 expr_line = -1;
5550
5551 if (cb_flag_remove_unreachable == 0) {
5552 /* Do not remove the code */
5553 cond_fixed = -1;
5554 return;
5555 }
5556
5557 if (rslt == cb_true) {
5558 cond_fixed = 0;
5559 } else
5560 if (rslt == cb_false) {
5561 cond_fixed = 1;
5562 } else {
5563 cond_fixed = -1;
5564 }
5565 }
5566
5567 /* Save this 'condition' result */
5568 void
5569 cb_save_cond (void)
5570 {
5571 if (if_stop) {
5572 return;
5573 }
5574 if (if_nest < MAX_NESTED_COND) {
5575 if_cond[if_nest++] = cond_fixed;
5576 } else {
5577 /* result: errors won't be ignored in "false" condition parts */
5578 cb_warning (COBC_WARN_FILLER,
5579 _("more than %d nested conditions"), MAX_NESTED_COND);
5580 if_stop = 1;
5581 if_nest = 0;
5582 cb_set_ignore_error (0);
5583 }
5584 }
5585
5586 /* TRUE side of 'condition' */
5587 void
5588 cb_true_side (void)
5589 {
5590 if (cond_fixed == 1) {
5591 cb_set_ignore_error (1);
5592 } else {
5593 cb_set_ignore_error (0);
5594 }
5595 }
5596
5597 /* FALSE side of 'condition' */
5598 void
5599 cb_false_side (void)
5600 {
5601 if (cond_fixed == 0) {
5602 cb_set_ignore_error (1);
5603 } else {
5604 cb_set_ignore_error (0);
5605 }
5606 }
5607
5608 /* END of statement that had a 'condition' */
5609 void
5610 cb_terminate_cond (void)
5611 {
5612 if (if_stop)
5613 return;
5614 if_nest--;
5615 if (if_nest <= 0) {
5616 cond_fixed = -1;
5617 cb_set_ignore_error (0);
5618 if_nest = 0;
5619 } else {
5620 cond_fixed = if_cond[if_nest];
5621 }
5622 }
5623
5624 /* Now at PERIOD, ending statement(s) */
5625 void
5626 cb_end_statement (void)
5627 {
5628 expr_dmax = -1;
5629 expr_dec_align = -1;
5630 expr_nest = 0;
5631 if_stop = 0;
5632 if_nest = 0;
5633 cb_set_ignore_error (0);
5634 expr_line = -1;
5635 }
5636
5637 /* ADD/SUBTRACT CORRESPONDING */
5638
5639 static cb_tree
5640 cb_build_optim_add (cb_tree v, cb_tree n)
5641 {
5642 size_t z;
5643 const char *s;
5644 struct cb_field *f;
5645
5646 if (CB_REF_OR_FIELD_P (v)) {
5647 f = CB_FIELD_PTR (v);
5648 if (!f->pic) {
5649 return CB_BUILD_FUNCALL_3 ("cob_add_int", v,
5650 cb_build_cast_int (n),
5651 cb_int0);
5652 }
5653 if ( !f->pic->scale
5654 && (f->usage == CB_USAGE_BINARY
5655 || f->usage == CB_USAGE_COMP_5
5656 || f->usage == CB_USAGE_COMP_X
5657 || f->usage == CB_USAGE_COMP_N)) {
5658 z = ((size_t)f->size - 1)
5659 + (8 * (f->pic->have_sign ? 1 : 0))
5660 + (16 * (f->flag_binary_swap ? 1 : 0));
5661 #if defined(COB_NON_ALIGNED) && !defined(_MSC_VER) && defined(COB_ALLOW_UNALIGNED)
5662 switch (f->size) {
5663 case 2:
5664 #ifdef COB_SHORT_BORK
5665 optimize_defs[bin_add_funcs[z].optim_val] = 1;
5666 s = bin_add_funcs[z].optim_name;
5667 break;
5668 #endif
5669 case 4:
5670 case 8:
5671 if (f->storage != CB_STORAGE_LINKAGE
5672 && f->indexes == 0
5673 && (f->offset % f->size) == 0) {
5674 optimize_defs[align_bin_add_funcs[z].optim_val] = 1;
5675 s = align_bin_add_funcs[z].optim_name;
5676 } else {
5677 optimize_defs[bin_add_funcs[z].optim_val] = 1;
5678 s = bin_add_funcs[z].optim_name;
5679 }
5680 break;
5681 default:
5682 optimize_defs[bin_add_funcs[z].optim_val] = 1;
5683 s = bin_add_funcs[z].optim_name;
5684 break;
5685 }
5686 #else
5687 #ifdef COB_ALLOW_UNALIGNED
5688 if (f->usage == CB_USAGE_COMP_5) {
5689 switch (f->size) {
5690 case 1:
5691 case 2:
5692 case 4:
5693 case 8:
5694 return cb_build_assign (v, cb_build_binary_op (v, '+', n));
5695 default:
5696 break;
5697 }
5698 }
5699 #endif
5700 optimize_defs[bin_add_funcs[z].optim_val] = 1;
5701 s = bin_add_funcs[z].optim_name;
5702 #endif
5703 if (s) {
5704 return CB_BUILD_FUNCALL_2 (s,
5705 CB_BUILD_CAST_ADDRESS (v),
5706 cb_build_cast_int (n));
5707 }
5708 } else if (!f->pic->scale && f->usage == CB_USAGE_PACKED &&
5709 f->pic->digits < 10) {
5710 optimize_defs[COB_ADD_PACKED_INT] = 1;
5711 return CB_BUILD_FUNCALL_2 ("cob_add_packed_int",
5712 v, cb_build_cast_int (n));
5713 }
5714 }
5715 return CB_BUILD_FUNCALL_3 ("cob_add_int", v,
5716 cb_build_cast_int (n), cb_int0);
5717 }
5718
5719 static cb_tree
5720 cb_build_optim_sub (cb_tree v, cb_tree n)
5721 {
5722 size_t z;
5723 const char *s;
5724 struct cb_field *f;
5725
5726 if (CB_REF_OR_FIELD_P (v)) {
5727 f = CB_FIELD_PTR (v);
5728 if ( !f->pic->scale
5729 && (f->usage == CB_USAGE_BINARY
5730 || f->usage == CB_USAGE_COMP_5
5731 || f->usage == CB_USAGE_COMP_X
5732 || f->usage == CB_USAGE_COMP_N)) {
5733 z = ((size_t)f->size - 1)
5734 + (8 * (f->pic->have_sign ? 1 : 0))
5735 + (16 * (f->flag_binary_swap ? 1 : 0));
5736 #if defined(COB_NON_ALIGNED) && !defined(_MSC_VER) && defined(COB_ALLOW_UNALIGNED)
5737 switch (f->size) {
5738 case 2:
5739 #ifdef COB_SHORT_BORK
5740 optimize_defs[bin_sub_funcs[z].optim_val] = 1;
5741 s = bin_sub_funcs[z].optim_name;
5742 break;
5743 #endif
5744 case 4:
5745 case 8:
5746 if (f->storage != CB_STORAGE_LINKAGE &&
5747 f->indexes == 0 && (f->offset % f->size) == 0) {
5748 optimize_defs[align_bin_sub_funcs[z].optim_val] = 1;
5749 s = align_bin_sub_funcs[z].optim_name;
5750 } else {
5751 optimize_defs[bin_sub_funcs[z].optim_val] = 1;
5752 s = bin_sub_funcs[z].optim_name;
5753 }
5754 break;
5755 default:
5756 optimize_defs[bin_sub_funcs[z].optim_val] = 1;
5757 s = bin_sub_funcs[z].optim_name;
5758 break;
5759 }
5760 #else
5761 #ifdef COB_ALLOW_UNALIGNED
5762 if (f->usage == CB_USAGE_COMP_5) {
5763 switch (f->size) {
5764 case 1:
5765 case 2:
5766 case 4:
5767 case 8:
5768 return cb_build_assign (v, cb_build_binary_op (v, '-', n));
5769 default:
5770 break;
5771 }
5772 }
5773 #endif
5774 optimize_defs[bin_sub_funcs[z].optim_val] = 1;
5775 s = bin_sub_funcs[z].optim_name;
5776 #endif
5777 if (s) {
5778 return CB_BUILD_FUNCALL_2 (s,
5779 CB_BUILD_CAST_ADDRESS (v),
5780 cb_build_cast_int (n));
5781 }
5782 }
5783 }
5784 return CB_BUILD_FUNCALL_3 ("cob_sub_int", v,
5785 cb_build_cast_int (n), cb_int0);
5786 }
5787
5788 cb_tree
5789 cb_build_add (cb_tree v, cb_tree n, cb_tree round_opt)
5790 {
5791 cb_tree opt;
5792 struct cb_field *f;
5793
5794 #ifdef COB_NON_ALIGNED
5795 if (CB_INDEX_OR_HANDLE_P (v)) {
5796 return cb_build_move (cb_build_binary_op (v, '+', n), v);
5797 }
5798 if (CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
5799 optimize_defs[COB_POINTER_MANIP] = 1;
5800 return CB_BUILD_FUNCALL_3 ("cob_pointer_manip", v, n, cb_int0);
5801 }
5802 #else
5803 if (CB_INDEX_OR_HANDLE_P (v) || CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
5804 return cb_build_move (cb_build_binary_op (v, '+', n), v);
5805 }
5806 #endif
5807
5808 if (CB_REF_OR_FIELD_P (v)) {
5809 f = CB_FIELD_PTR (v);
5810 f->count++;
5811 }
5812 if (CB_REF_OR_FIELD_P (n)) {
5813 f = CB_FIELD_PTR (n);
5814 f->count++;
5815 }
5816 if (round_opt == cb_high) {
5817 /* Short circuit from tree.c for perform */
5818 if (cb_fits_int (n)) {
5819 return cb_build_optim_add (v, n);
5820 } else {
5821 return CB_BUILD_FUNCALL_3 ("cob_add", v, n, cb_int0);
5822 }
5823 }
5824 opt = build_store_option (v, round_opt);
5825 if (opt == cb_int0 && cb_fits_int (n)) {
5826 return cb_build_optim_add (v, n);
5827 }
5828 return CB_BUILD_FUNCALL_3 ("cob_add", v, n, opt);
5829 }
5830
5831 cb_tree
5832 cb_build_sub (cb_tree v, cb_tree n, cb_tree round_opt)
5833 {
5834 cb_tree opt;
5835 struct cb_field *f;
5836
5837 #ifdef COB_NON_ALIGNED
5838 if (CB_INDEX_OR_HANDLE_P (v)) {
5839 return cb_build_move (cb_build_binary_op (v, '-', n), v);
5840 }
5841 if (CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
5842 optimize_defs[COB_POINTER_MANIP] = 1;
5843 return CB_BUILD_FUNCALL_3 ("cob_pointer_manip", v, n, cb_int1);
5844 }
5845 #else
5846 if (CB_INDEX_OR_HANDLE_P (v) || CB_TREE_CLASS (v) == CB_CLASS_POINTER) {
5847 return cb_build_move (cb_build_binary_op (v, '-', n), v);
5848 }
5849 #endif
5850
5851 if (CB_REF_OR_FIELD_P (v)) {
5852 f = CB_FIELD_PTR (v);
5853 f->count++;
5854 }
5855 if (CB_REF_OR_FIELD_P (n)) {
5856 f = CB_FIELD_PTR (n);
5857 f->count++;
5858 }
5859 opt = build_store_option (v, round_opt);
5860 if (opt == cb_int0 && cb_fits_int (n)) {
5861 return cb_build_optim_sub (v, n);
5862 }
5863 return CB_BUILD_FUNCALL_3 ("cob_sub", v, n, opt);
5864 }
5865
5866 static unsigned int
5867 emit_corresponding (cb_tree (*func) (cb_tree f1, cb_tree f2, cb_tree f3),
5868 cb_tree x1, cb_tree x2, cb_tree opt)
5869 {
5870 struct cb_field *f1, *f2;
5871 cb_tree t1;
5872 cb_tree t2;
5873 unsigned int found;
5874
5875 found = 0;
5876 for (f1 = CB_FIELD_PTR (x1)->children; f1; f1 = f1->sister) {
5877 if (!f1->redefines && !f1->flag_occurs) {
5878 for (f2 = CB_FIELD_PTR (x2)->children; f2; f2 = f2->sister) {
5879 if (!f2->redefines && !f2->flag_occurs) {
5880 if (strcmp (f1->name, f2->name) == 0) {
5881 t1 = cb_build_field_reference (f1, x1);
5882 t2 = cb_build_field_reference (f2, x2);
5883 if (f1->children && f2->children) {
5884 found += emit_corresponding (func, t1, t2, opt);
5885 } else {
5886 if ((CB_TREE_CATEGORY (t1) == CB_CATEGORY_NUMERIC) &&
5887 (CB_TREE_CATEGORY (t2) == CB_CATEGORY_NUMERIC)) {
5888 found++;
5889 cb_emit (func (t1, t2, opt));
5890 }
5891 }
5892 }
5893 }
5894 }
5895 }
5896 }
5897 return found;
5898 }
5899
5900 void
5901 cb_emit_corresponding (cb_tree (*func) (cb_tree f1, cb_tree f2, cb_tree f3),
5902 cb_tree x1, cb_tree x2, cb_tree opt)
5903 {
5904 x1 = cb_check_group_name (x1);
5905 x2 = cb_check_group_name (x2);
5906
5907 if (cb_validate_one (x1)) {
5908 return;
5909 }
5910 if (cb_validate_one (x2)) {
5911 return;
5912 }
5913
5914 if (!emit_corresponding (func, x1, x2, opt)) {
5915 cb_warning_x (cb_warn_corresponding, x2, _("no CORRESPONDING items found"));
5916 }
5917 }
5918
5919 void
5920 cb_emit_tab_arithmetic (cb_tree (*func) (cb_tree f1, cb_tree f2, cb_tree f3),
5921 cb_tree x1, cb_tree x2, cb_tree opt, cb_tree from_to_idx, cb_tree dest_idx)
5922 {
5923 if (cb_validate_one (x1)) {
5924 return;
5925 }
5926 if (cb_tree_category (x1) != CB_CATEGORY_NUMERIC) {
5927 cb_error_x (x1, _("'%s' is not numeric"), cb_name (x1));
5928 }
5929
5930 if (cb_validate_one (x2)) {
5931 return;
5932 }
5933 if (cb_tree_category (x2) != CB_CATEGORY_NUMERIC) {
5934 cb_error_x (x2, _("'%s' is not numeric"), cb_name (x2));
5935 }
5936
5937 /* TODO pending, no actual code generation */
5938 COB_UNUSED (func);
5939 COB_UNUSED (opt);
5940 COB_UNUSED (from_to_idx);
5941 COB_UNUSED (dest_idx);
5942 }
5943
5944 static unsigned int
5945 emit_move_corresponding (cb_tree x1, cb_tree x2)
5946 {
5947 struct cb_field *f1, *f2;
5948 cb_tree t1;
5949 cb_tree t2;
5950 unsigned int found;
5951
5952 found = 0;
5953 for (f1 = CB_FIELD_PTR (x1)->children; f1; f1 = f1->sister) {
5954 if (!f1->redefines && !f1->flag_occurs) {
5955 for (f2 = CB_FIELD_PTR (x2)->children; f2; f2 = f2->sister) {
5956 if (!f2->redefines && !f2->flag_occurs) {
5957 if (strcmp (f1->name, f2->name) == 0) {
5958 t1 = cb_build_field_reference (f1, x1);
5959 t2 = cb_build_field_reference (f2, x2);
5960 if (f1->children && f2->children) {
5961 found += emit_move_corresponding (t1, t2);
5962 } else {
5963 cb_emit (cb_build_move (t1, t2));
5964 found++;
5965 }
5966 }
5967 }
5968 }
5969 }
5970 }
5971 return found;
5972 }
5973
5974 void
5975 cb_emit_move_corresponding (cb_tree source, cb_tree target_list)
5976 {
5977 cb_tree l;
5978 cb_tree target;
5979
5980 source = cb_check_group_name (source);
5981 if (cb_validate_one (source)) {
5982 return;
5983 }
5984 for (l = target_list; l; l = CB_CHAIN(l)) {
5985 target = CB_VALUE(l);
5986 target = cb_check_group_name (target);
5987 if (cb_validate_one (target)) {
5988 return;
5989 }
5990 if (!emit_move_corresponding (source, target)) {
5991 cb_warning_x (cb_warn_corresponding, target, _("no CORRESPONDING items found"));
5992 } else if (cb_listing_xref) {
5993 cobc_xref_set_receiving (target);
5994 }
5995 }
5996 }
5997
5998 static unsigned int
5999 emit_accept_external_form (cb_tree x)
6000 {
6001 struct cb_field *f;
6002 cb_tree f_ref, f_ref_2, ext_form_id, index_lit;
6003 int i;
6004 char buff[32];
6005 unsigned int found = 0;
6006
6007 for (f = CB_FIELD_PTR (x)->children; f; f = f->sister) {
6008 if (f->redefines) {
6009 continue;
6010 }
6011
6012 if (f->children) {
6013 f_ref = cb_build_field_reference (f, x);
6014 found += emit_accept_external_form (f_ref);
6015 continue;
6016 }
6017
6018 if (f->external_form_identifier) {
6019 ext_form_id = f->external_form_identifier;
6020 } else {
6021 ext_form_id = cb_build_alphanumeric_literal (f->name, strlen (f->name));
6022 }
6023 if (f->flag_occurs) {
6024 for (i = 1; i <= f->occurs_max; i++) {
6025 sprintf (buff, "%d", i);
6026 index_lit = cb_build_numeric_literal(0, buff, 0);
6027
6028 f_ref_2 = cb_build_field_reference (f, x);
6029 CB_REFERENCE (f_ref_2)->subs = CB_LIST_INIT (index_lit);
6030
6031 #if 0 /* TODO: implement CGI runtime, see Patch #27 */
6032 cb_emit (CB_BUILD_FUNCALL_3 ("cob_cgi_getCgiValue",
6033 ext_form_id, index_lit,
6034 f_ref_2));
6035 #endif
6036 }
6037 #if 0 /* TODO: implement CGI runtime, see Patch #27 */
6038 } else {
6039 index_lit = cb_build_numeric_literal (0, "1", 0);
6040 cb_emit (CB_BUILD_FUNCALL_3 ("cob_cgi_getCgiValue",
6041 ext_form_id, index_lit,
6042 f_ref));
6043 #else
6044 COB_UNUSED (ext_form_id);
6045 #endif
6046 }
6047 found++;
6048 }
6049
6050 return found;
6051 }
6052
6053 static void
6054 cb_emit_accept_external_form (cb_tree x1)
6055 {
6056 cb_tree x2;
6057
6058 x2 = cb_check_group_name (x1);
6059 if (cb_validate_one (x2)) {
6060 return;
6061 }
6062 if (!emit_accept_external_form (x2)) {
6063 cb_warning_x (COBC_WARN_FILLER, x1, _("no items to ACCEPT found"));
6064 }
6065 }
6066
6067 static unsigned int
6068 emit_display_external_form (cb_tree x)
6069 {
6070 struct cb_field *f, *f_ref_field;
6071 cb_tree f_ref, ext_form_id;
6072 unsigned int found = 0;
6073
6074 for (f = CB_FIELD_PTR (x)->children; f; f = f->sister) {
6075 if (f->redefines || f->flag_occurs) {
6076 continue;
6077 }
6078
6079 f_ref = cb_build_field_reference (f, x);
6080 if (f->children) {
6081 found += emit_display_external_form (f_ref);
6082 } else {
6083 /* TO-DO: Is CB_FIELD (cb_ref (f_ref)) == f? */
6084 f_ref_field = CB_FIELD (cb_ref (f_ref));
6085 if (f_ref_field->external_form_identifier) {
6086 ext_form_id = f_ref_field->external_form_identifier;
6087 } else {
6088 ext_form_id = cb_build_alphanumeric_literal (f_ref_field->name,
6089 strlen (f_ref_field->name));
6090 }
6091 #if 0 /* TODO: implement CGI runtime, see Patch #27 */
6092 cb_emit (CB_BUILD_FUNCALL_2 ("cob_cgi_addTplVar", ext_form_id, f_ref));
6093 #else
6094 COB_UNUSED (ext_form_id);
6095 #endif
6096 found++;
6097 }
6098 }
6099
6100 return found;
6101 }
6102
6103 static void
6104 cb_emit_display_external_form (cb_tree x1)
6105 {
6106 cb_tree x2;
6107
6108 x2 = cb_check_group_name (x1);
6109 if (cb_validate_one (x2)) {
6110 return;
6111 }
6112 if (!emit_display_external_form (x2)) {
6113 cb_warning_x (COBC_WARN_FILLER, x1, _("no items to DISPLAY found"));
6114 }
6115 }
6116
6117 static int
6118 get_screen_type (const struct cb_field * const p)
6119 {
6120 if (p->children) {
6121 return COB_SCREEN_TYPE_GROUP;
6122 } else if (p->values) {
6123 return COB_SCREEN_TYPE_VALUE;
6124 } else if (p->size > 0) {
6125 return COB_SCREEN_TYPE_FIELD;
6126 } else {
6127 return COB_SCREEN_TYPE_ATTRIBUTE;
6128 }
6129 }
6130
6131 static void
6132 output_screen_from (struct cb_field *p, const unsigned int sisters)
6133 {
6134 int type;
6135
6136 if (sisters && p->sister) {
6137 output_screen_from (p->sister, 1U);
6138 }
6139 if (p->children) {
6140 output_screen_from (p->children, 1U);
6141 }
6142
6143 type = get_screen_type (p);
6144 if (type == COB_SCREEN_TYPE_FIELD && p->screen_from) {
6145 /* Bump reference count */
6146 p->count++;
6147 cb_emit (CB_BUILD_FUNCALL_2 ("cob_move", p->screen_from,
6148 CB_TREE (p)));
6149 }
6150 }
6151
6152 static void
6153 output_screen_to (struct cb_field *p, const unsigned int sisters)
6154 {
6155 int type;
6156
6157 if (sisters && p->sister) {
6158 output_screen_to (p->sister, 1U);
6159 }
6160 if (p->children) {
6161 output_screen_to (p->children, 1U);
6162 }
6163
6164 type = get_screen_type (p);
6165 if (type == COB_SCREEN_TYPE_FIELD && p->screen_to) {
6166 /* Bump reference count */
6167 p->count++;
6168 cb_emit (CB_BUILD_FUNCALL_2 ("cob_move", CB_TREE (p), p->screen_to));
6169 }
6170 }
6171
6172 /* ACCEPT statement */
6173
6174 static int
6175 numeric_screen_pos_type (struct cb_field *pos)
6176 {
6177 return pos->pic
6178 && pos->pic->category == CB_CATEGORY_NUMERIC
6179 && pos->pic->scale == 0;
6180 }
6181
6182 static int
6183 numeric_children_screen_pos_type (struct cb_field* child)
6184 {
6185 child = child->children;
6186 if (!child) return 0;
6187
6188 for (; child; child = child->sister) {
6189 if (!numeric_screen_pos_type (child)) {
6190 return 0;
6191 }
6192 }
6193
6194 return 1;
6195 }
6196
6197 static int
6198 valid_screen_pos (cb_tree pos)
6199 {
6200 cb_tree pos_ref = pos;
6201 int size = -1;
6202
6203 /* Find size of pos value, if possible */
6204 if (CB_INVALID_TREE (pos)) {
6205 return 0;
6206 }
6207 if (CB_REFERENCE_P (pos)) {
6208 pos = cb_ref (pos);
6209 }
6210 if (CB_LITERAL_P (pos)) {
6211 if (CB_TREE_CATEGORY (pos) == CB_CATEGORY_NUMERIC) {
6212 size = CB_LITERAL (pos)->size;
6213 } else {
6214 size = -1;
6215 }
6216 } else if (CB_FIELD_P (pos)) {
6217 struct cb_field *field = CB_FIELD (pos);
6218 if (numeric_screen_pos_type (field)) {
6219 size = field->pic->size;
6220 } else if (numeric_children_screen_pos_type (field)) {
6221 size = field->size;
6222 }
6223 } else if (pos == cb_zero) {
6224 cb_error_x (pos_ref, _("cannot specify figurative constant ZERO in AT clause"));
6225 return 0;
6226 }
6227 if (size == -1) {
6228 cb_error_x (pos_ref, _("value in AT clause is not numeric"));
6229 return 0;
6230 }
6231
6232 /* Check if size is valid. If it isn't, display error. */
6233 if (size != 4 && size != 6) {
6234 cb_error_x (pos_ref, _("value in AT clause must have 4 or 6 digits"));
6235 return 0;
6236 } else {
6237 return 1;
6238 }
6239 }
6240
6241 static void
6242 get_line_and_column_from_pos (const cb_tree pos, cb_tree * const line_or_pos,
6243 cb_tree * const column)
6244 {
6245 if (!pos) {
6246 *line_or_pos = NULL;
6247 *column = NULL;
6248 } else if (CB_PAIR_P (pos)) {
6249 *line_or_pos = CB_PAIR_X (pos);
6250 *column = CB_PAIR_Y (pos);
6251 /* Note: This must not be done for column where we need the 0,
6252 otherwise screenio.c (extract_line_and_col_vals) would
6253 evaluate the field "line" as a combined position */
6254 if (*line_or_pos == cb_int0) {
6255 *line_or_pos = NULL;
6256 }
6257 } else if (valid_screen_pos (pos)) {
6258 *line_or_pos = pos;
6259 *column = NULL;
6260 }
6261 }
6262
6263 static void
6264 cb_gen_field_accept (cb_tree var, cb_tree pos, cb_tree fgc, cb_tree bgc,
6265 cb_tree scroll, cb_tree timeout, cb_tree prompt,
6266 cb_tree size_is, cob_flags_t disp_attrs)
6267 {
6268 cb_tree line = NULL;
6269 cb_tree column = NULL;
6270
6271 if (!pos) {
6272 cb_emit (CB_BUILD_FUNCALL_10 ("cob_field_accept",
6273 var, NULL, NULL, fgc, bgc, scroll,
6274 timeout, prompt, size_is, cb_flags_t (disp_attrs)));
6275 } else if (CB_LIST_P (pos)) {
6276 get_line_and_column_from_pos (pos, &line, &column);
6277 cb_emit (CB_BUILD_FUNCALL_10 ("cob_field_accept",
6278 var, line, column, fgc, bgc, scroll,
6279 timeout, prompt, size_is, cb_flags_t (disp_attrs)));
6280 } else if (valid_screen_pos (pos)) {
6281 cb_emit (CB_BUILD_FUNCALL_10 ("cob_field_accept",
6282 var, pos, NULL, fgc, bgc, scroll,
6283 timeout, prompt, size_is, cb_flags_t (disp_attrs)));
6284 }
6285 }
6286
6287 static COB_INLINE COB_A_INLINE int
6288 line_col_zero_is_supported (void)
6289 {
6290 return cb_accept_display_extensions == CB_OK
6291 || cb_accept_display_extensions == CB_WARNING
6292 || cb_accept_display_extensions == CB_ARCHAIC
6293 || cb_accept_display_extensions == CB_OBSOLETE;
6294 }
6295
6296 void
6297 cb_emit_accept (cb_tree var, cb_tree pos, struct cb_attr_struct *attr_ptr)
6298 {
6299 cb_tree line;
6300 cb_tree column;
6301 cb_tree fgc;
6302 cb_tree bgc;
6303 cb_tree scroll;
6304 cb_tree timeout;
6305 cb_tree prompt;
6306 cb_tree size_is; /* WITH SIZE IS */
6307 cob_flags_t disp_attrs;
6308
6309 if (cb_validate_one (var)) {
6310 return;
6311 }
6312 if (cb_listing_xref) {
6313 cobc_xref_set_receiving (var);
6314 }
6315
6316 if (attr_ptr) {
6317 fgc = attr_ptr->fgc;
6318 bgc = attr_ptr->bgc;
6319 scroll = attr_ptr->scroll;
6320 timeout = attr_ptr->timeout;
6321 prompt = attr_ptr->prompt;
6322 size_is = attr_ptr->size_is;
6323 disp_attrs = attr_ptr->dispattrs;
6324 if (cb_validate_one (pos)
6325 || cb_validate_one (fgc)
6326 || cb_validate_one (bgc)
6327 || cb_validate_one (scroll)
6328 || cb_validate_one (timeout)
6329 || cb_validate_one (prompt)
6330 || cb_validate_one (size_is)) {
6331 return;
6332 }
6333 } else {
6334 fgc = NULL;
6335 bgc = NULL;
6336 scroll = NULL;
6337 timeout = NULL;
6338 prompt = NULL;
6339 size_is = NULL;
6340 disp_attrs = 0;
6341 }
6342
6343 if (prompt) {
6344 /* PROMPT character - 1 character identifier or literal */
6345 if (CB_LITERAL_P (prompt)) {
6346 if (CB_LITERAL (prompt)->size != 1) {
6347 cb_error_x (prompt, _("invalid PROMPT literal"));
6348 return;
6349 }
6350 } else {
6351 if (CB_FIELD_PTR (prompt)->size != 1) {
6352 cb_error_x (prompt, _("invalid PROMPT identifier"));
6353 return;
6354 }
6355 }
6356 }
6357
6358 /* CGI: ACCEPT external-form */
6359 /* TODO: CHECKME, see Patch #27 */
6360 if (CB_REF_OR_FIELD_P (var) && CB_FIELD (cb_ref (var))->flag_is_external_form) {
6361 cb_emit_accept_external_form (var);
6362 return;
6363 }
6364
6365 #if 0 /* RXWRXW - Screen */
6366 if ((CB_REF_OR_FIELD_P (var)) &&
6367 CB_FIELD (cb_ref (var))->storage == CB_STORAGE_SCREEN) {
6368 current_program->flag_screen = 1;
6369 }
6370 #endif
6371
6372 if (current_program->flag_screen) {
6373 /* Bump ref count to force CRT STATUS field generation
6374 and include it in cross-reference */
6375 if (current_program->crt_status) {
6376 CB_FIELD_PTR (current_program->crt_status)->count++;
6377 if (cb_listing_xref) {
6378 cobc_xref_set_receiving (current_program->crt_status);
6379 }
6380 }
6381 if ((CB_REF_OR_FIELD_P (var)) &&
6382 CB_FIELD_PTR (var)->storage == CB_STORAGE_SCREEN) {
6383 output_screen_from (CB_FIELD_PTR (var), 0);
6384 gen_screen_ptr = 1;
6385 if (pos) {
6386 if (CB_LIST_P (pos)) {
6387 line = CB_PAIR_X (pos);
6388 column = CB_PAIR_Y (pos);
6389 cb_emit (CB_BUILD_FUNCALL_5 ("cob_screen_accept",
6390 var, line, column, timeout,
6391 cb_int (line_col_zero_is_supported ())));
6392 } else if (valid_screen_pos (pos)) {
6393 cb_emit (CB_BUILD_FUNCALL_5 ("cob_screen_accept",
6394 var, pos, NULL, timeout,
6395 cb_int (line_col_zero_is_supported ())));
6396 }
6397 } else {
6398 cb_emit (CB_BUILD_FUNCALL_5 ("cob_screen_accept",
6399 var, NULL, NULL, timeout,
6400 cb_int (line_col_zero_is_supported ())));
6401 }
6402 gen_screen_ptr = 0;
6403 output_screen_to (CB_FIELD (cb_ref (var)), 0);
6404 } else {
6405 if (var == cb_null) {
6406 var = NULL;
6407 }
6408 if (pos || fgc || bgc || scroll || disp_attrs) {
6409 cb_gen_field_accept (var, pos, fgc, bgc, scroll,
6410 timeout, prompt, size_is, disp_attrs);
6411 } else {
6412 cb_emit (CB_BUILD_FUNCALL_10 ("cob_field_accept",
6413 var, NULL, NULL, fgc, bgc,
6414 scroll, timeout, prompt,
6415 size_is, cb_flags_t (disp_attrs)));
6416 }
6417 }
6418 } else if (pos || fgc || bgc || scroll || disp_attrs
6419 || timeout || prompt || size_is) {
6420 /* Bump ref count to force CRT STATUS field generation
6421 and include it in cross-reference */
6422 if (current_program->crt_status) {
6423 CB_FIELD_PTR (current_program->crt_status)->count++;
6424 if (cb_listing_xref) {
6425 cobc_xref_set_receiving (current_program->crt_status);
6426 }
6427 }
6428 if (var == cb_null) {
6429 var = NULL;
6430 }
6431 cb_gen_field_accept (var, pos, fgc, bgc, scroll,
6432 timeout, prompt, size_is, disp_attrs);
6433 } else {
6434 if (var == cb_null) {
6435 var = NULL;
6436 }
6437 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept", var));
6438 }
6439 }
6440
6441 void
6442 cb_emit_accept_line_or_col (cb_tree var, const int l_or_c)
6443 {
6444 if (cb_validate_one (var)) {
6445 return;
6446 }
6447 if (cb_listing_xref) {
6448 cobc_xref_set_receiving (var);
6449 }
6450 cb_emit (CB_BUILD_FUNCALL_2 ("cob_screen_line_col", var, cb_int (l_or_c)));
6451 }
6452
6453 void
6454 cb_emit_accept_escape_key (cb_tree var)
6455 {
6456 if (cb_validate_one (var)) {
6457 return;
6458 }
6459 if (cb_listing_xref) {
6460 cobc_xref_set_receiving (var);
6461 }
6462 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_escape_key", var));
6463 }
6464
6465 void
6466 cb_emit_accept_exception_status (cb_tree var)
6467 {
6468 if (cb_validate_one (var)) {
6469 return;
6470 }
6471 if (cb_listing_xref) {
6472 cobc_xref_set_receiving (var);
6473 }
6474 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_exception_status", var));
6475 }
6476
6477 void
6478 cb_emit_accept_user_name (cb_tree var)
6479 {
6480 if (cb_validate_one (var)) {
6481 return;
6482 }
6483 if (cb_listing_xref) {
6484 cobc_xref_set_receiving (var);
6485 }
6486 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_user_name", var));
6487 }
6488
6489 void
6490 cb_emit_accept_date (cb_tree var)
6491 {
6492 if (cb_validate_one (var)) {
6493 return;
6494 }
6495 if (cb_listing_xref) {
6496 cobc_xref_set_receiving (var);
6497 }
6498 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_date", var));
6499 }
6500
6501 void
6502 cb_emit_accept_date_yyyymmdd (cb_tree var)
6503 {
6504 if (cb_validate_one (var)) {
6505 return;
6506 }
6507 if (cb_listing_xref) {
6508 cobc_xref_set_receiving (var);
6509 }
6510 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_date_yyyymmdd", var));
6511 }
6512
6513 void
6514 cb_emit_accept_day (cb_tree var)
6515 {
6516 if (cb_validate_one (var)) {
6517 return;
6518 }
6519 if (cb_listing_xref) {
6520 cobc_xref_set_receiving (var);
6521 }
6522 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_day", var));
6523 }
6524
6525 void
6526 cb_emit_accept_day_yyyyddd (cb_tree var)
6527 {
6528 if (cb_validate_one (var)) {
6529 return;
6530 }
6531 if (cb_listing_xref) {
6532 cobc_xref_set_receiving (var);
6533 }
6534 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_day_yyyyddd", var));
6535 }
6536
6537 void
6538 cb_emit_accept_day_of_week (cb_tree var)
6539 {
6540 if (cb_validate_one (var)) {
6541 return;
6542 }
6543 if (cb_listing_xref) {
6544 cobc_xref_set_receiving (var);
6545 }
6546 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_day_of_week", var));
6547 }
6548
6549 void
6550 cb_emit_accept_time (cb_tree var)
6551 {
6552 if (cb_validate_one (var)) {
6553 return;
6554 }
6555 if (cb_listing_xref) {
6556 cobc_xref_set_receiving (var);
6557 }
6558 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_time", var));
6559 }
6560
6561 void
6562 cb_emit_accept_command_line (cb_tree var)
6563 {
6564 if (cb_validate_one (var)) {
6565 return;
6566 }
6567 if (cb_listing_xref) {
6568 cobc_xref_set_receiving (var);
6569 }
6570 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_command_line", var));
6571 }
6572
6573 void
6574 cb_emit_get_environment (cb_tree envvar, cb_tree envval)
6575 {
6576 if (cb_validate_one (envvar)) {
6577 return;
6578 }
6579 if (cb_listing_xref) {
6580 cobc_xref_set_receiving (envvar);
6581 }
6582 if (cb_validate_one (envval)) {
6583 return;
6584 }
6585 cb_emit (CB_BUILD_FUNCALL_2 ("cob_get_environment", envvar, envval));
6586 }
6587
6588 void
6589 cb_emit_accept_environment (cb_tree var)
6590 {
6591 if (cb_validate_one (var)) {
6592 return;
6593 }
6594 if (cb_listing_xref) {
6595 cobc_xref_set_receiving (var);
6596 }
6597 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_environment", var));
6598 }
6599
6600 void
6601 cb_emit_accept_arg_number (cb_tree var)
6602 {
6603 if (cb_validate_one (var)) {
6604 return;
6605 }
6606 if (cb_listing_xref) {
6607 cobc_xref_set_receiving (var);
6608 }
6609 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_arg_number", var));
6610 }
6611
6612 void
6613 cb_emit_accept_arg_value (cb_tree var)
6614 {
6615 if (cb_validate_one (var)) {
6616 return;
6617 }
6618 if (cb_listing_xref) {
6619 cobc_xref_set_receiving (var);
6620 }
6621 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept_arg_value", var));
6622 }
6623
6624 void
6625 cb_emit_accept_mnemonic (cb_tree var, cb_tree mnemonic)
6626 {
6627 cb_tree mnemonic_ref;
6628
6629 if (cb_validate_one (var)) {
6630 return;
6631 }
6632 mnemonic_ref = cb_ref (mnemonic);
6633 if (mnemonic_ref == cb_error_node) {
6634 return;
6635 }
6636 switch (CB_SYSTEM_NAME (mnemonic_ref)->token) {
6637 case CB_DEVICE_CONSOLE:
6638 case CB_DEVICE_SYSIN:
6639 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept", var));
6640 break;
6641 default:
6642 cb_error_x (mnemonic, _("'%s' is not an input device"),
6643 cb_name (mnemonic));
6644 break;
6645 }
6646 }
6647
6648 void
6649 cb_emit_accept_name (cb_tree var, cb_tree name)
6650 {
6651 cb_tree sys;
6652
6653 if (cb_validate_one (var)) {
6654 return;
6655 }
6656 if (cb_listing_xref) {
6657 cobc_xref_set_receiving (var);
6658 }
6659
6660 /* Allow direct reference to a device name (not defined as mnemonic name) */
6661 sys = get_system_name (CB_NAME (name));
6662 if (sys) {
6663 switch (CB_SYSTEM_NAME (sys)->token) {
6664 case CB_DEVICE_CONSOLE:
6665 case CB_DEVICE_SYSIN:
6666 /* possibly others allow this, too, consider adding a config option */
6667 if (cb_std_define != CB_STD_IBM
6668 && cb_std_define != CB_STD_MVS
6669 && cb_std_define != CB_STD_MF
6670 && !cb_relaxed_syntax_checks) {
6671 cb_warning_x (COBC_WARN_FILLER, name,
6672 _("'%s' is not defined in SPECIAL-NAMES"), CB_NAME (name));
6673 }
6674 cb_emit (CB_BUILD_FUNCALL_1 ("cob_accept", var));
6675 return;
6676 default:
6677 cb_error_x (name, _("invalid input device '%s'"),
6678 cb_name (name));
6679 return;
6680 }
6681 } else if (is_default_reserved_word (CB_NAME (name))) {
6682 cb_error_x (name, _("unknown device '%s'; it may exist in another dialect"),
6683 CB_NAME (name));
6684 } else {
6685 cb_error_x (name, _("unknown device '%s'; not defined in SPECIAL-NAMES"),
6686 CB_NAME (name));
6687 }
6688 }
6689
6690 /* ALLOCATE statement */
6691
6692 void
6693 cb_emit_allocate (cb_tree target1, cb_tree target2, cb_tree size,
6694 cb_tree initialize)
6695 {
6696 cb_tree x;
6697 char buff[32];
6698
6699 if (cb_validate_one (target1)
6700 || cb_validate_one (target2)
6701 || cb_validate_one (size)
6702 || cb_validate_one (initialize)) {
6703 return;
6704 }
6705 if (target1) {
6706 if (!(CB_REFERENCE_P(target1) &&
6707 CB_FIELD_PTR (target1)->flag_item_based)) {
6708 cb_error_x (CB_TREE(current_statement),
6709 _("target of ALLOCATE is not a BASED item"));
6710 return;
6711 }
6712 if (cb_listing_xref) {
6713 cobc_xref_set_receiving (target1);
6714 }
6715 }
6716 if (target2) {
6717 if (!(CB_REFERENCE_P(target2) &&
6718 CB_TREE_CLASS (target2) == CB_CLASS_POINTER)) {
6719 cb_error_x (CB_TREE(current_statement),
6720 _("target of RETURNING is not a data pointer"));
6721 return;
6722 }
6723 if (cb_listing_xref) {
6724 cobc_xref_set_receiving (target2);
6725 }
6726 }
6727 if (size) {
6728 if (CB_TREE_CLASS (size) != CB_CLASS_NUMERIC) {
6729 cb_error_x (CB_TREE(current_statement),
6730 _("amount must be specified as a numeric expression"));
6731 return;
6732 }
6733 }
6734 if (target1) {
6735 sprintf (buff, "%d", CB_FIELD_PTR (target1)->memory_size);
6736 x = cb_build_numeric_literal (0, buff, 0);
6737 cb_emit (CB_BUILD_FUNCALL_4 ("cob_allocate",
6738 CB_BUILD_CAST_ADDR_OF_ADDR (target1),
6739 target2, x, NULL));
6740 } else {
6741 if (initialize && !cb_category_is_alpha (initialize)) {
6742 cb_error_x (CB_TREE(current_statement),
6743 _("INITIALIZED TO item is not alphanumeric"));
6744 }
6745 cb_emit (CB_BUILD_FUNCALL_4 ("cob_allocate",
6746 NULL, target2, size, initialize));
6747 }
6748 if (initialize && target1) {
6749 current_statement->not_ex_handler =
6750 cb_build_initialize (target1, cb_true, NULL, 1, 0, 0);
6751 }
6752 }
6753
6754
6755 /* ALTER statement */
6756
6757 void
6758 cb_emit_alter (cb_tree source, cb_tree target)
6759 {
6760 if (source == cb_error_node) {
6761 return;
6762 }
6763 if (target == cb_error_node) {
6764 return;
6765 }
6766 CB_REFERENCE(source)->flag_alter_code = 1;
6767 cb_emit (cb_build_alter (source, target));
6768 }
6769
6770 /* CALL statement */
6771
6772 static const char *
6773 get_constant_call_name (cb_tree prog)
6774 {
6775 /* plain literal or constant (level 78 item, 01 CONSTANT, SYMBOLIC CONSTANT) */
6776 if (CB_LITERAL_P (prog) && CB_TREE_CATEGORY (prog) != CB_CATEGORY_NUMERIC) {
6777 return (const char *)CB_LITERAL (prog)->data;
6778 /* reference (ideally on a prototype) */
6779 } else if (CB_REFERENCE_P (prog)) {
6780 cb_tree x = cb_ref (prog);
6781 if (CB_PROTOTYPE_P (x)) {
6782 return CB_PROTOTYPE (x)->ext_name;
6783 }
6784 }
6785 return NULL;
6786 }
6787
6788 void
6789 cb_emit_call (cb_tree prog, cb_tree par_using, cb_tree returning,
6790 cb_tree on_exception, cb_tree not_on_exception,
6791 cb_tree convention, cb_tree newthread, cb_tree handle,
6792 int call_line_number)
6793 {
6794 cb_tree l;
6795 cb_tree check_list;
6796 cb_tree x;
6797 struct cb_field *f;
6798 const struct system_table *psyst;
6799 const char *entry;
6800 const char *constant_call_name = get_constant_call_name (prog);
6801 char c;
6802 cob_s64_t val;
6803 cob_s64_t valmin;
6804 cob_s64_t valmax;
6805 cob_u32_t is_sys_call;
6806 cob_u32_t is_sys_idx;
6807 int error_ind;
6808 int call_conv;
6809 unsigned int numargs;
6810
6811 if (CB_INTRINSIC_P (prog)) {
6812 if (CB_INTRINSIC (prog)->intr_tab->category != CB_CATEGORY_ALPHANUMERIC) {
6813 cb_error_x (CB_TREE (current_statement),
6814 _("only alphanumeric FUNCTION types are allowed here"));
6815 return;
6816 }
6817 }
6818 if (returning && returning != cb_null) {
6819 if (CB_TREE_CLASS (returning) != CB_CLASS_NUMERIC &&
6820 CB_TREE_CLASS (returning) != CB_CLASS_POINTER) {
6821 cb_error_x (CB_TREE (current_statement),
6822 _("invalid RETURNING field"));
6823 return;
6824 }
6825 }
6826
6827 error_ind = 0;
6828
6829 if (convention) {
6830 if (CB_INTEGER_P (convention)) {
6831 call_conv = CB_INTEGER (convention)->val;
6832 } else {
6833 call_conv = cb_get_int (convention);
6834 }
6835 } else {
6836 call_conv = 0;
6837 }
6838 #ifndef _WIN32
6839 if (call_conv & CB_CONV_STDCALL) {
6840 call_conv &= ~CB_CONV_STDCALL;
6841 cb_warning (cb_warn_additional, _("STDCALL not available on this platform"));
6842 }
6843 #elif defined(_WIN64)
6844 if (call_conv & CB_CONV_STDCALL) {
6845 cb_warning (cb_warn_additional, _("STDCALL used on 64-bit Windows platform"));
6846 }
6847 #endif
6848 if ((call_conv & CB_CONV_STATIC_LINK) && !constant_call_name) {
6849 cb_error_x (CB_TREE (current_statement),
6850 _("STATIC CALL convention requires a literal program name"));
6851 error_ind = 1;
6852 }
6853
6854 if (handle && !usage_is_thread_handle(handle)) {
6855 cb_error_x (handle, _("HANDLE must be either a generic or a THREAD HANDLE"));
6856 error_ind = 1;
6857 }
6858
6859 numargs = 0;
6860 check_list = NULL;
6861 for (l = par_using; l; l = CB_CHAIN (l), numargs++) {
6862 x = CB_VALUE (l);
6863 if (x == cb_error_node) {
6864 error_ind = 1;
6865 continue;
6866 }
6867 if (CB_NUMERIC_LITERAL_P (x)) {
6868 if (CB_PURPOSE_INT (l) != CB_CALL_BY_VALUE) {
6869 continue;
6870 }
6871 if (CB_SIZES_INT_UNSIGNED(l) &&
6872 CB_LITERAL (x)->sign < 0) {
6873 cb_error_x (x, _("numeric literal is negative"));
6874 error_ind = 1;
6875 continue;
6876 }
6877 val = 0;
6878 valmin = 0;
6879 valmax = 0;
6880 switch (CB_SIZES_INT (l)) {
6881 case CB_SIZE_1:
6882 val = cb_get_long_long (x);
6883 if (CB_SIZES_INT_UNSIGNED(l)) {
6884 valmin = 0;
6885 valmax = UCHAR_MAX;
6886 } else {
6887 valmin = CHAR_MIN;
6888 valmax = CHAR_MAX;
6889 }
6890 break;
6891 case CB_SIZE_2:
6892 val = cb_get_long_long (x);
6893 if (CB_SIZES_INT_UNSIGNED(l)) {
6894 valmin = 0;
6895 valmax = USHRT_MAX;
6896 } else {
6897 valmin = SHRT_MIN;
6898 valmax = SHRT_MAX;
6899 }
6900 break;
6901 case CB_SIZE_4:
6902 val = cb_get_long_long (x);
6903 if (CB_SIZES_INT_UNSIGNED(l)) {
6904 valmin = 0;
6905 valmax = UINT_MAX;
6906 } else {
6907 valmin = INT_MIN;
6908 valmax = INT_MAX;
6909 }
6910 break;
6911 case CB_SIZE_8:
6912 case CB_SIZE_AUTO:
6913 if (CB_SIZES_INT_UNSIGNED(l)) {
6914 if (CB_LITERAL (x)->size < 20) {
6915 break;
6916 }
6917 if (CB_LITERAL (x)->size > 20) {
6918 valmin = 1;
6919 break;
6920 }
6921 if (memcmp (CB_LITERAL (x)->data,
6922 "18446744073709551615",
6923 (size_t)20) > 0) {
6924 valmin = 1;
6925 break;
6926 }
6927 } else {
6928 if (CB_LITERAL (x)->size < 19) {
6929 break;
6930 }
6931 if (CB_LITERAL (x)->size > 19) {
6932 valmin = 1;
6933 break;
6934 }
6935 if (memcmp (CB_LITERAL (x)->data,
6936 CB_LITERAL (x)->sign ?
6937 "9223372036854775808" :
6938 "9223372036854775807",
6939 (size_t)19) > 0) {
6940 valmin = 1;
6941 break;
6942 }
6943 }
6944 break;
6945 default:
6946 break;
6947 }
6948 if (!valmin && !valmax) {
6949 continue;
6950 }
6951 if (val < valmin || val > valmax) {
6952 cb_error_x (x, _("numeric literal exceeds size limits"));
6953 error_ind = 1;
6954 }
6955 continue;
6956 }
6957 if (CB_CONST_P (x) && x != cb_null) {
6958 if (x == cb_space ||
6959 x == cb_norm_low ||
6960 x == cb_norm_high||
6961 x == cb_quote) {
6962 c = (char)get_value (x);
6963 x = cb_build_alphanumeric_literal (&c, 1);
6964 } else if (x == cb_zero) {
6965 x = cb_build_numsize_literal ("0", 1, 0);
6966 } else{
6967 cb_error_x (x, _ ("figurative constant %s invalid here"), cb_name (x));
6968 error_ind = 1;
6969 continue;
6970 }
6971 }
6972 if (CB_FIELD_P (x)) { /* TODO: remove after 3.1 RC1 */
6973 cobc_abort ("should be not be a field", 1);
6974 }
6975 if ((CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value))) {
6976 f = CB_FIELD (cb_ref (x));
6977 if (f->level == 88) {
6978 cb_error_x (x, _("'%s' is not a valid data name"), CB_NAME (x));
6979 error_ind = 1;
6980 continue;
6981 }
6982 if (CB_PURPOSE_INT (l) == CB_CALL_BY_REFERENCE) {
6983 if (f->level != 01 && f->level != 77) {
6984 cb_warning_x (cb_warn_call_params, x,
6985 _("'%s' is not a 01 or 77 level item"), CB_NAME (x));
6986 }
6987 check_list = cb_list_add (check_list, x);
6988 } else if (f->flag_any_length) {
6989 cb_error_x (x, _("'%s' ANY LENGTH item not passed BY REFERENCE"), CB_NAME (x));
6990 error_ind = 1;
6991 continue;
6992 }
6993
6994 }
6995 }
6996
6997 if (check_list != NULL) {
6998 for (l = check_list; l; l = CB_CHAIN (l)) {
6999 cb_tree l2 = CB_VALUE (l);
7000 x = cb_ref (l2);
7001 if (x != cb_error_node) {
7002 for (l2 = check_list; l2 != l; l2 = CB_CHAIN (l2)) {
7003 if (cb_ref (CB_VALUE (l2)) == x) {
7004 cb_warning_x (COBC_WARN_FILLER, l,
7005 _("duplicate USING BY REFERENCE item '%s'"),
7006 cb_name (CB_VALUE (l)));
7007 CB_VALUE (l) = cb_error_node;
7008 break;
7009 }
7010 }
7011 }
7012 }
7013 }
7014
7015 is_sys_call = 0;
7016 if (constant_call_name) {
7017 const char *p = constant_call_name;
7018 entry = p;
7019 for (; *p; ++p) {
7020 if (*p == '/' || *p == '\\') {
7021 entry = p + 1;
7022 }
7023
7024 }
7025
7026 is_sys_idx = 1;
7027 for (psyst = system_tab; psyst->syst_name; psyst++, is_sys_idx++) {
7028 if (!strcmp(entry, (const char *)psyst->syst_name)) {
7029 char *name;
7030 char xname[7];
7031 if (psyst->syst_name[1]) {
7032 name = (char *)psyst->syst_name;
7033 } else {
7034 sprintf (xname, "X\"%2X\"", (unsigned char)psyst->syst_name[0]);
7035 name = (char *)&xname;
7036 }
7037 if (psyst->syst_params_min > numargs) {
7038 cb_error_x (CB_TREE (current_statement),
7039 _("wrong number of CALL parameters for '%s', %d given, %d expected"),
7040 name, numargs, psyst->syst_params_min);
7041 return;
7042 } else if (psyst->syst_params_max < numargs) {
7043 cb_warning_x (COBC_WARN_FILLER, CB_TREE (current_statement),
7044 _("wrong number of CALL parameters for '%s', %d given, %d expected"),
7045 name, numargs, psyst->syst_params_max);
7046 }
7047 is_sys_call = is_sys_idx;
7048 break;
7049 }
7050 }
7051 if (cb_listing_xref) {
7052 cobc_xref_call (entry, call_line_number, 0, is_sys_call);
7053 }
7054 }
7055 else if (cb_listing_xref && CB_REFERENCE_P(prog)) {
7056 entry = CB_FIELD(CB_REFERENCE(prog)->value)->name;
7057 cobc_xref_call (entry, call_line_number, 1, 0);
7058 }
7059
7060 if (error_ind) {
7061 return;
7062 }
7063
7064 /* adjust maximum call parameters for later generation */
7065 if (numargs > current_program->max_call_param) {
7066 current_program->max_call_param = numargs;
7067 }
7068
7069 #if 0 /* TODO: implement THREADs in libcob */
7070 /* remark: this won't work as the CALL has to be started in the new thread
7071 if (newthread) {
7072 cb_emit (CB_BUILD_FUNCALL_0 ("cob_threadstart"));
7073 }
7074 if (handle) {
7075 cb_emit (CB_BUILD_FUNCALL_1 ("cob_get_threadhandle", handle));
7076 } */
7077 #else
7078 COB_UNUSED (newthread);
7079 #endif
7080 cb_emit (cb_build_call (prog, par_using, on_exception, not_on_exception,
7081 returning, is_sys_call, call_conv));
7082 }
7083
7084 /* CANCEL statement */
7085
7086 void
7087 cb_emit_cancel (cb_tree prog)
7088 {
7089 if (cb_validate_one (prog)) {
7090 return;
7091 }
7092 cb_emit (cb_build_cancel (prog));
7093 }
7094
7095 /* CLOSE statement */
7096
7097 void
7098 cb_emit_close (cb_tree file, cb_tree opt)
7099 {
7100 struct cb_file *f;
7101
7102 file = cb_ref (file);
7103 if (file == cb_error_node) {
7104 return;
7105 }
7106 current_statement->file = file;
7107 f = CB_FILE (file);
7108
7109 if (f->organization == COB_ORG_SORT) {
7110 cb_error_x (CB_TREE (current_statement),
7111 _("%s not allowed on %s files"), "CLOSE", "SORT");
7112 }
7113
7114 if (f->extfh) {
7115 cb_emit (CB_BUILD_FUNCALL_5 ("cob_extfh_close", f->extfh, file,
7116 f->file_status, opt, cb_int0));
7117 } else {
7118 cb_emit (CB_BUILD_FUNCALL_4 ("cob_close", file,
7119 f->file_status, opt, cb_int0));
7120 }
7121
7122 /* Check for file debugging */
7123 if (current_program->flag_debugging &&
7124 !current_statement->flag_in_debug &&
7125 CB_FILE(file)->flag_fl_debug) {
7126 cb_emit (cb_build_debug (cb_debug_name, f->name, NULL));
7127 cb_emit (cb_build_move (cb_space, cb_debug_contents));
7128 cb_emit (cb_build_debug_call (f->debug_section));
7129 }
7130 }
7131
7132 /* COMMIT statement */
7133
7134 void
7135 cb_emit_commit (void)
7136 {
7137 cb_emit (CB_BUILD_FUNCALL_0 ("cob_commit"));
7138 }
7139
7140 /* CONTINUE statement */
7141
7142 void
7143 cb_emit_continue (cb_tree continue_after)
7144 {
7145 if (continue_after) {
7146 /* CONTINUE AFTER exp SECONDS */
7147 if (!cb_verify (cb_continue_after, _("AFTER phrase in CONTINUE statement"))
7148 || cb_validate_one (continue_after)) {
7149 return;
7150 }
7151 if (CB_TREE_CLASS (continue_after) != CB_CLASS_NUMERIC) {
7152 cb_error_x (CB_TREE(current_statement),
7153 _("amount must be specified as a numeric expression"));
7154 return;
7155 }
7156 cb_emit (CB_BUILD_FUNCALL_1 ("cob_continue_after",
7157 continue_after));
7158 return;
7159 }
7160 /* "common" CONTINUE */
7161 cb_emit (cb_build_continue ());
7162 }
7163
7164 /* DELETE statement */
7165
7166 void
7167 cb_emit_delete (cb_tree file)
7168 {
7169 struct cb_file *f;
7170
7171 file = cb_ref (file);
7172 if (file == cb_error_node) {
7173 return;
7174 }
7175 current_statement->file = file;
7176 f = CB_FILE (file);
7177
7178 if (cb_listing_xref) {
7179 /* add a "receiving" entry for the file */
7180 cobc_xref_link (&f->xref, current_statement->common.source_line, 1);
7181 }
7182
7183 if (f->organization == COB_ORG_SORT) {
7184 cb_error_x (CB_TREE (current_statement),
7185 _("%s not allowed on %s files"), "DELETE", "SORT");
7186 return;
7187 } else if (f->organization == COB_ORG_LINE_SEQUENTIAL) {
7188 cb_error_x (CB_TREE (current_statement),
7189 _("%s not allowed on %s files"), "DELETE", "LINE SEQUENTIAL");
7190 return;
7191 }
7192
7193 /* Check for file debugging */
7194 if (current_program->flag_debugging &&
7195 !current_statement->flag_in_debug &&
7196 f->flag_fl_debug) {
7197 /* Gen callback after delete but before exception test */
7198 current_statement->flag_callback = 1;
7199 }
7200
7201 if (f->extfh) {
7202 cb_emit (CB_BUILD_FUNCALL_3 ("cob_extfh_delete", f->extfh, file,
7203 f->file_status));
7204 } else {
7205 cb_emit (CB_BUILD_FUNCALL_2 ("cob_delete", file,
7206 f->file_status));
7207 }
7208 }
7209
7210 void
7211 cb_emit_delete_file (cb_tree file)
7212 {
7213 file = cb_ref (file);
7214 if (file == cb_error_node) {
7215 return;
7216 }
7217 if (CB_FILE (file)->organization == COB_ORG_SORT) {
7218 cb_error_x (CB_TREE (current_statement),
7219 _("%s not allowed on %s files"), "DELETE FILE", "SORT");
7220 return;
7221 }
7222
7223 /* Check for file debugging */
7224 if (current_program->flag_debugging &&
7225 !current_statement->flag_in_debug &&
7226 CB_FILE(file)->flag_fl_debug) {
7227 /* Gen callback after delete but before exception test */
7228 current_statement->flag_callback = 1;
7229 }
7230
7231 cb_emit (CB_BUILD_FUNCALL_2 ("cob_delete_file", file,
7232 CB_FILE(file)->file_status));
7233 }
7234
7235
7236 static int
7237 validate_attrs (cb_tree pos, cb_tree fgc, cb_tree bgc, cb_tree scroll, cb_tree size_is)
7238 {
7239 return cb_validate_one (pos)
7240 || cb_validate_one (fgc)
7241 || cb_validate_one (bgc)
7242 || cb_validate_one (scroll)
7243 || cb_validate_one (size_is);
7244 }
7245
7246 static void
7247 initialize_attrs (const struct cb_attr_struct * const attr_ptr,
7248 cb_tree * const fgc, cb_tree * const bgc,
7249 cb_tree * const scroll, cb_tree * const size_is,
7250 cob_flags_t * const dispattrs)
7251 {
7252 if (attr_ptr) {
7253 *fgc = attr_ptr->fgc;
7254 *bgc = attr_ptr->bgc;
7255 *scroll = attr_ptr->scroll;
7256 *size_is = attr_ptr->size_is;
7257 *dispattrs = attr_ptr->dispattrs;
7258 } else {
7259 *fgc = NULL;
7260 *bgc = NULL;
7261 *scroll = NULL;
7262 *size_is = NULL;
7263 *dispattrs = 0;
7264 }
7265 }
7266
7267
7268 /* DISPLAY [FLOATING | INITIAL] WINDOW statement */
7269
7270 void
7271 cb_emit_display_window (cb_tree type, cb_tree own_handle, cb_tree upon_handle,
7272 cb_tree line_column, struct cb_attr_struct *attr_ptr)
7273 {
7274 cb_tree fgc;
7275 cb_tree bgc;
7276 cb_tree scroll;
7277 cb_tree size_is; /* WITH SIZE IS */
7278 cob_flags_t disp_attrs;
7279
7280 /* type may be: NULL --> normal WINDOW,
7281 cb_int0 --> FLOATING WINDOW
7282 otherwise it is an INITIAL WINDOW type:
7283 cb_int1 = INITIAL, cb_int2 = STANDARD, cb_int3 = INDEPENDENT */
7284 if ((type == cb_int1 || type == cb_int2) && line_column != NULL) {
7285 cb_error_x (line_column, _("positions cannot be specified for main windows"));
7286 }
7287
7288 /* Validate line_column and the attributes */
7289 initialize_attrs (attr_ptr, &fgc, &bgc, &scroll, &size_is, &disp_attrs);
7290 if (validate_attrs (line_column, fgc, bgc, scroll, size_is)) {
7291 return;
7292 }
7293
7294 if (own_handle && !usage_is_window_handle (own_handle)) {
7295 cb_error_x (own_handle, _("HANDLE must be either a generic or a WINDOW HANDLE or X(10)"));
7296 }
7297 if (upon_handle && !usage_is_window_handle (upon_handle)) {
7298 cb_error_x (upon_handle, _("HANDLE must be either a generic or a WINDOW HANDLE or X(10)"));
7299 }
7300
7301 #if 0 /* TODO, likely as multiple functions */
7302 cb_emit (CB_BUILD_FUNCALL_2 ("cob_display_window", own_handle, upon_handle));
7303 #endif
7304 }
7305
7306
7307 /* CLOSE WINDOW statement (WITH NO DISPLAY)
7308 Note: CLOSE WINDOW without WITH NO DISPLAY is resolved as cb_emit_destroy
7309 */
7310
7311 void
7312 cb_emit_close_window (cb_tree handle, cb_tree no_display)
7313 {
7314 if (handle && !usage_is_window_handle (handle)) {
7315 cb_error_x (handle, _("HANDLE must be either a generic or a WINDOW HANDLE or X(10)"));
7316 }
7317 if (no_display) {
7318 cb_emit (CB_BUILD_FUNCALL_1 ("cob_close_window", handle));
7319 } else {
7320 cb_emit_destroy (CB_LIST_INIT (handle));
7321 }
7322 }
7323
7324
7325 /* DESTROY statement */
7326
7327 void
7328 cb_emit_destroy (cb_tree controls)
7329 {
7330 #if 0 /* TODO */
7331 cb_tree l;
7332 struct cb_field *f;
7333 int i;
7334 #endif
7335
7336 /* DESTROY ALL CONTROLS */
7337 if (!controls) {
7338 cb_emit (CB_BUILD_FUNCALL_1 ("cob_destroy_control", NULL));
7339 return;
7340 }
7341
7342 /* DESTROY list-of-controls */
7343 if (cb_validate_list (controls)) {
7344 return;
7345 }
7346 #if 0 /* TODO */
7347 for (l = controls, i = 1; l; l = CB_CHAIN (l), i++) {
7348 if (CB_REF_OR_FIELD_P (CB_VALUE (l))) {
7349 f = CB_FIELD_PTR (CB_VALUE (l));
7350 if (!f->...checks) {
7351 ...
7352 }
7353 cb_emit (CB_BUILD_FUNCALL_1 ("cob_destroy_control", CB_VALUE (l)));
7354 } else {
7355 ...
7356 }
7357 }
7358 #endif
7359 }
7360
7361 /* DISPLAY statement */
7362
7363 void
7364 cb_emit_env_name (cb_tree value)
7365 {
7366 if (cb_validate_one (value)) {
7367 return;
7368 }
7369 cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_environment", value));
7370 }
7371
7372 void
7373 cb_emit_env_value (cb_tree value)
7374 {
7375 if (cb_validate_one (value)) {
7376 return;
7377 }
7378 cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_env_value", value));
7379 }
7380
7381 void
7382 cb_emit_arg_number (cb_tree value)
7383 {
7384 if (cb_validate_one (value)) {
7385 return;
7386 }
7387 cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_arg_number", value));
7388 }
7389
7390 void
7391 cb_emit_command_line (cb_tree value)
7392 {
7393 if (cb_validate_one (value)) {
7394 return;
7395 }
7396 cb_emit (CB_BUILD_FUNCALL_1 ("cob_display_command_line", value));
7397 }
7398
7399 /*
7400 Return 1 if a value in the list values has an unexpected type (tree tag, to be
7401 precise) or is an error node. Otherwise, return 0.
7402 */
7403 static int
7404 validate_types_of_display_values (cb_tree values)
7405 {
7406 cb_tree l;
7407 cb_tree x;
7408
7409 for (l = values; l; l = CB_CHAIN (l)) {
7410 x = CB_VALUE (l);
7411 if (x == cb_error_node) {
7412 return 1;
7413 }
7414
7415 switch (CB_TREE_TAG (x)) {
7416 case CB_TAG_LITERAL:
7417 case CB_TAG_INTRINSIC:
7418 case CB_TAG_CONST:
7419 case CB_TAG_STRING:
7420 case CB_TAG_INTEGER:
7421 break;
7422 case CB_TAG_REFERENCE:
7423 if (!CB_FIELD_P(CB_REFERENCE(x)->value)) {
7424 cb_error_x (x, _("'%s' is an invalid type for DISPLAY operand"), cb_name (x));
7425 return 1;
7426 }
7427 break;
7428 default:
7429 cb_error_x (x, _("invalid type for DISPLAY operand"));
7430 return 1;
7431 }
7432 }
7433
7434 return 0;
7435 }
7436
7437 static void
7438 emit_device_display (cb_tree values, cb_tree upon, cb_tree no_adv)
7439 {
7440 cb_tree p;
7441
7442 p = CB_BUILD_FUNCALL_3 ("cob_display", upon, no_adv, values);
7443 CB_FUNCALL (p)->varcnt = (int)cb_list_length (values);
7444 CB_FUNCALL (p)->nolitcast = 1;
7445 cb_emit (p);
7446 }
7447
7448 static void
7449 increment_field_ref_counts (cb_tree value_list)
7450 {
7451 cb_tree x;
7452
7453 for (; value_list; value_list = CB_CHAIN (value_list)) {
7454 x = CB_VALUE (value_list);
7455 if (CB_FIELD_P (x)) {
7456 CB_FIELD (cb_ref (x))->count++;
7457 }
7458 }
7459 }
7460
7461 static void
7462 emit_screen_display (const cb_tree x, const cb_tree pos)
7463 {
7464 cb_tree line = NULL;
7465 cb_tree column = NULL;
7466
7467 get_line_and_column_from_pos (pos, &line, &column);
7468 cb_emit (CB_BUILD_FUNCALL_4 ("cob_screen_display", x, line, column,
7469 cb_int (line_col_zero_is_supported ())));
7470 }
7471
7472 static void
7473 process_special_values (cb_tree value, cb_tree * const size_is, cob_flags_t * const attrs)
7474 {
7475 /*
7476 The following are MF extensions. MF specifically
7477 states X"01", X"02" and X"07", so the values do not
7478 need to be changed for other codesets.
7479
7480 For all special values, the SIZE clause is ignored.
7481 */
7482
7483 /* LOW-VALUES positions cursor */
7484 if (value == cb_low) {
7485 *attrs |= COB_SCREEN_NO_DISP;
7486 *size_is = NULL;
7487 return;
7488 }
7489
7490 if (!cb_display_special_fig_consts) {
7491 return;
7492 }
7493
7494 /* SPACE clears to end of screen */
7495 if (value == cb_space) {
7496 *attrs |= COB_SCREEN_ERASE_EOS;
7497 *attrs |= COB_SCREEN_NO_DISP;
7498 *size_is = NULL;
7499 } else if (CB_LITERAL_P (value) && CB_LITERAL (value)->all &&
7500 CB_LITERAL (value)->size == 1) {
7501 if (CB_LITERAL (value)->data[0] == '\1') {
7502 /* ASCII char \1 is SOH, start of header */
7503 *attrs |= COB_SCREEN_ERASE_EOL;
7504 *attrs |= COB_SCREEN_NO_DISP;
7505 *size_is = NULL;
7506 } else if (CB_LITERAL (value)->data[0] == '\2') {
7507 /* ASCII char \2 is STX, start of text */
7508 cb_emit (CB_BUILD_FUNCALL_0 ("cob_sys_clear_screen"));
7509 /* We might still need to position the cursor */
7510 *attrs |= COB_SCREEN_NO_DISP;
7511 *size_is = NULL;
7512 } else if (CB_LITERAL (value)->data[0] == '\7') {
7513 /* ASCII char \7 is BEL, bell */
7514 *attrs |= COB_SCREEN_BELL;
7515 *attrs |= COB_SCREEN_NO_DISP;
7516 *size_is = NULL;
7517 }
7518 }
7519 }
7520
7521 static void
7522 emit_field_display (const cb_tree x, const cb_tree pos, const cb_tree fgc,
7523 const cb_tree bgc, const cb_tree scroll,
7524 const cb_tree size_is, const cob_flags_t disp_attrs)
7525 {
7526 cb_tree line_or_pos = NULL;
7527 cb_tree column = NULL;
7528
7529 get_line_and_column_from_pos (pos, &line_or_pos, &column);
7530 cb_emit (CB_BUILD_FUNCALL_8 ("cob_field_display",
7531 x, line_or_pos, column, fgc, bgc,
7532 scroll, size_is,
7533 cb_flags_t (disp_attrs)));
7534 }
7535
7536 static cb_tree
7537 get_integer_literal_pair (const char *value)
7538 {
7539 const cb_tree num = cb_build_numeric_literal (1, value, 0);
7540
7541 return CB_BUILD_PAIR (num, num);
7542 }
7543
7544 static COB_INLINE COB_A_INLINE cb_tree
7545 get_after_last_line_column (void)
7546 {
7547 return get_integer_literal_pair ("0");
7548 }
7549
7550 static COB_INLINE COB_A_INLINE cb_tree
7551 get_origin_line_column (void)
7552 {
7553 return get_integer_literal_pair ("1");
7554 }
7555
7556 static void
7557 emit_screen_displays (cb_tree screen_list, cb_tree line_col_for_last)
7558 {
7559 cb_tree l;
7560 cb_tree pos;
7561 cb_tree screen_ref;
7562
7563 /* note: screen_list validated by caller cb_emit_display */
7564 for (l = screen_list; l; l = CB_CHAIN (l)) {
7565 /*
7566 LINE 1 COL 1 is assumed, not LINE 0 COL 0 as in field
7567 DISPLAYs. (This is RM-COBOL behaviour, who support multiple
7568 screens in one DISPLAY.)
7569 */
7570 if (CB_CHAIN (l) || !line_col_for_last) {
7571 pos = get_origin_line_column ();
7572 } else {
7573 pos = line_col_for_last;
7574 }
7575
7576 screen_ref = CB_VALUE (l);
7577 output_screen_from (CB_FIELD (cb_ref (screen_ref)), 0);
7578
7579 gen_screen_ptr = 1;
7580 emit_screen_display (screen_ref, pos);
7581 gen_screen_ptr = 0;
7582 }
7583 }
7584
7585 static cb_tree
7586 get_default_field_line_column (const int is_first_display_item)
7587 {
7588 /*
7589 Note if LINE/COL 0 is not allowed, then this must be a
7590 standard format DISPLAY (DISPLAY ... UPON CRT), which must
7591 follow previous items, unlike the DISPLAY with screen clauses
7592 (DISPLAY ... WITH HIGHLIGHT, etc.).
7593 */
7594 const int display_after_last =
7595 !line_col_zero_is_supported ()
7596 || !is_first_display_item
7597 || cb_line_col_zero_default;
7598
7599 if (display_after_last) {
7600 return get_after_last_line_column ();
7601 } else {
7602 return get_origin_line_column ();
7603 }
7604
7605 }
7606
7607 static void
7608 emit_default_field_display_for_all_but_last (cb_tree values, cb_tree size_is,
7609 const int is_first_display_list)
7610 {
7611 cb_tree l;
7612 int is_first_display_item = is_first_display_list;
7613 cb_tree pos;
7614 cob_flags_t disp_attrs;
7615 cb_tree x;
7616
7617 /* LCOV_EXCL_START */
7618 if (!values) {
7619 cobc_err_msg (_("call to '%s' with invalid parameter '%s'"),
7620 "emit_default_field_display_for_all_but_last", "values");
7621 COBC_ABORT ();
7622 }
7623 /* LCOV_EXCL_STOP */
7624
7625 for (l = values; l && CB_CHAIN (l); l = CB_CHAIN (l)) {
7626 pos = get_default_field_line_column (is_first_display_item);
7627 is_first_display_item = 0;
7628
7629 x = CB_VALUE (l);
7630 disp_attrs = 0;
7631 process_special_values (x, &size_is, &disp_attrs);
7632
7633 emit_field_display (x, pos, NULL, NULL, NULL, NULL, disp_attrs);
7634 }
7635 }
7636
7637 static void
7638 emit_field_display_for_last (cb_tree values, cb_tree line_column, cb_tree fgc,
7639 cb_tree bgc, cb_tree scroll, cb_tree size_is,
7640 cob_flags_t disp_attrs,
7641 const int is_first_display_list)
7642 {
7643 cb_tree l;
7644 cb_tree last_elt;
7645 int is_first_item;
7646
7647 /* DISPLAY OMITTED ? */
7648 if (values == cb_null) {
7649 l = last_elt = cb_null;
7650 } else {
7651 for (l = values; l && CB_CHAIN (l); l = CB_CHAIN (l));
7652 /* LCOV_EXCL_START */
7653 if (!l) {
7654 cobc_err_msg (_("call to '%s' with invalid parameter '%s'"),
7655 "emit_field_display_for_last", "values");
7656 COBC_ABORT ();
7657 }
7658 /* LCOV_EXCL_STOP */
7659 last_elt = CB_VALUE (l);
7660 }
7661
7662 if (line_column == NULL) {
7663 is_first_item = is_first_display_list && l == values;
7664 line_column = get_default_field_line_column (is_first_item);
7665 }
7666
7667 process_special_values (last_elt, &size_is, &disp_attrs);
7668 emit_field_display (last_elt, line_column, fgc, bgc, scroll, size_is,
7669 disp_attrs);
7670 }
7671
7672 void
7673 cb_emit_display (cb_tree values, cb_tree upon, cb_tree no_adv,
7674 cb_tree line_column, struct cb_attr_struct *attr_ptr,
7675 int is_first_display_list,
7676 const enum cb_display_type display_type)
7677 {
7678 cb_tree fgc;
7679 cb_tree bgc;
7680 cb_tree scroll;
7681 cb_tree size_is; /* WITH SIZE IS */
7682 cob_flags_t disp_attrs;
7683 cb_tree m;
7684 struct cb_field *f = NULL;
7685
7686 /* Validate upon and values */
7687 if (values != cb_null) /* DISPLAY OMITTED */ {
7688 if (upon == cb_error_node
7689 || !values
7690 || cb_validate_list (values)
7691 || validate_types_of_display_values (values)) {
7692 return;
7693 }
7694 }
7695
7696 /* Validate line_column and the attributes */
7697 initialize_attrs (attr_ptr, &fgc, &bgc, &scroll, &size_is, &disp_attrs);
7698 if (validate_attrs (line_column, fgc, bgc, scroll, size_is)) {
7699 return;
7700 }
7701
7702 /* Emit appropriate function call(s) */
7703 switch (display_type) {
7704 case DEVICE_DISPLAY:
7705
7706 /* CGI: DISPLAY external-form */
7707 /* TODO: CHECKME, see Patch #27 */
7708 m = CB_VALUE(values);
7709 if (CB_REF_OR_FIELD_P (m)) {
7710 f = CB_FIELD_PTR (m);
7711 }
7712 if (f && (f->flag_is_external_form || f->external_form_identifier)) {
7713 /* static content has both attributes */
7714 if (f->flag_is_external_form && f->external_form_identifier) {
7715 #if 0 /* TODO: implement CGI runtime, see Patch #27 */
7716 cb_emit (CB_BUILD_FUNCALL_1 ("cob_cgi_static", f->external_form_identifier));
7717 #endif
7718 return;
7719 }
7720 cb_emit_display_external_form (m);
7721 /* TODO: CHECKME, DISPLAY without identifier (template) is a "debug display" */
7722 if (f->external_form_identifier) {
7723 m = f->external_form_identifier;
7724 } else {
7725 m = cb_build_alphanumeric_literal (f->name, strlen(f->name));
7726 }
7727 #if 0 /* TODO: implement CGI runtime, see Patch #27 */
7728 cb_emit (CB_BUILD_FUNCALL_1 ("cob_cgi_renderTpl", m));
7729 #endif
7730 return;
7731 }
7732
7733 if (upon == NULL) {
7734 upon = cb_int0;
7735 }
7736 emit_device_display (values, upon, no_adv);
7737 increment_field_ref_counts (values);
7738 break;
7739
7740 case SCREEN_DISPLAY:
7741 emit_screen_displays (values, line_column);
7742 break;
7743
7744 case FIELD_ON_SCREEN_DISPLAY:
7745 /* no DISPLAY OMITTED */
7746 if (values != cb_null) {
7747 emit_default_field_display_for_all_but_last (values, size_is,
7748 is_first_display_list);
7749 }
7750 emit_field_display_for_last (values, line_column, fgc, bgc,
7751 scroll, size_is, disp_attrs,
7752 is_first_display_list);
7753
7754 break;
7755
7756 default:
7757 /* Any other type will already have emitted errors */
7758 ;
7759 }
7760 }
7761
7762 cb_tree
7763 cb_build_display_mnemonic (cb_tree x)
7764 {
7765 if (cb_ref (x) == cb_error_node) {
7766 return cb_int0;
7767 }
7768
7769 switch (CB_SYSTEM_NAME (cb_ref (x))->token) {
7770 case CB_DEVICE_CONSOLE:
7771 case CB_DEVICE_SYSOUT:
7772 return cb_int0;
7773 case CB_DEVICE_SYSERR:
7774 return cb_int1;
7775 case CB_DEVICE_PRINTER:
7776 return cb_int2;
7777 case CB_DEVICE_SYSPCH:
7778 return cb_int3;
7779 default:
7780 cb_error_x (x, _("'%s' is not an output device"), CB_NAME (x));
7781 return cb_int0;
7782 }
7783 }
7784
7785 cb_tree
7786 cb_build_display_name (cb_tree x)
7787 {
7788 const char *name;
7789 cb_tree sys;
7790
7791 if (x == cb_error_node) {
7792 return cb_error_node;
7793 }
7794 name = CB_NAME (x);
7795 /* Allow direct reference to a device name (not defined as mnemonic name) */
7796 sys = get_system_name (name);
7797 if (sys) {
7798 switch (CB_SYSTEM_NAME (sys)->token) {
7799 case CB_DEVICE_CONSOLE:
7800 case CB_DEVICE_SYSOUT:
7801 sys = cb_int0;
7802 break;
7803 case CB_DEVICE_SYSERR:
7804 sys = cb_int1;
7805 break;
7806 case CB_DEVICE_PRINTER:
7807 sys = cb_int2;
7808 break;
7809 case CB_DEVICE_SYSPCH:
7810 sys = cb_int3;
7811 break;
7812 default:
7813 cb_error_x (x, _("'%s' is not an output device"), name);
7814 return cb_error_node;
7815 }
7816 /* possibly others allow this, too, consider adding a config option */
7817 if (cb_std_define != CB_STD_IBM
7818 && cb_std_define != CB_STD_MVS
7819 && cb_std_define != CB_STD_MF
7820 && !cb_relaxed_syntax_checks) {
7821 /* ... especially as this is not allowed and therefore should raise an error... */
7822 cb_warning_x (COBC_WARN_FILLER, x,
7823 _("'%s' is not defined in SPECIAL-NAMES"), name);
7824 }
7825 return sys;
7826 } else if (is_default_reserved_word (CB_NAME (x))) {
7827 cb_error_x (x, _("unknown device '%s'; it may exist in another dialect"),
7828 name);
7829 } else {
7830 cb_error_x (x, _("unknown device '%s'; not defined in SPECIAL-NAMES"), name);
7831 }
7832 return cb_error_node;
7833 }
7834
7835 /* DIVIDE statement */
7836
7837 void
7838 cb_emit_divide (cb_tree dividend, cb_tree divisor, cb_tree quotient,
7839 cb_tree remainder)
7840 {
7841 cb_tree quotient_field, remainder_field;
7842
7843 if (cb_validate_one (dividend)
7844 || cb_validate_one (divisor)) {
7845 return;
7846 }
7847
7848 if (cb_validate_one (CB_VALUE(quotient))
7849 || cb_validate_one (CB_VALUE(remainder))) {
7850 return;
7851 }
7852 quotient_field = cb_check_numeric_edited_name (CB_VALUE(quotient));
7853 remainder_field = cb_check_numeric_edited_name (CB_VALUE(remainder));
7854
7855 if (quotient_field == cb_error_node
7856 || remainder_field == cb_error_node) {
7857 return;
7858 }
7859
7860 cb_emit (CB_BUILD_FUNCALL_4 ("cob_div_quotient", dividend, divisor,
7861 quotient_field, build_store_option (quotient_field, CB_PURPOSE (quotient))));
7862 cb_emit (CB_BUILD_FUNCALL_2 ("cob_div_remainder",
7863 remainder_field, build_store_option (remainder_field, cb_int0)));
7864 }
7865
7866 /* EVALUATE statement */
7867
7868 static cb_tree
7869 evaluate_test (cb_tree s, cb_tree o)
7870 {
7871 cb_tree x;
7872 cb_tree y;
7873 cb_tree t;
7874 int flag;
7875
7876 /* ANY is always true */
7877 if (o == cb_any) {
7878 return cb_true;
7879 }
7880
7881 /* Object TRUE or FALSE */
7882 if (o == cb_true) {
7883 return s;
7884 }
7885 if (o == cb_false) {
7886 return CB_BUILD_NEGATION (s);
7887 }
7888 if (o == cb_error_node) {
7889 return cb_error_node;
7890 }
7891
7892 flag = CB_PURPOSE_INT (o);
7893 x = CB_PAIR_X (CB_VALUE (o));
7894 y = CB_PAIR_Y (CB_VALUE (o));
7895
7896 /* Subject TRUE or FALSE */
7897 if (s == cb_true) {
7898 return flag ? CB_BUILD_NEGATION (x) : x;
7899 }
7900 if (s == cb_false) {
7901 return flag ? x : CB_BUILD_NEGATION (x);
7902 }
7903
7904 /* x THRU y */
7905 if (y) {
7906 t = cb_build_binary_op (cb_build_binary_op (x, '[', s),
7907 '&',
7908 cb_build_binary_op (s, '[', y));
7909
7910 return flag ? CB_BUILD_NEGATION (t) : t;
7911 }
7912
7913 if (CB_REFERENCE_P(x) && CB_FIELD_P(CB_REFERENCE(x)->value) &&
7914 CB_FIELD(CB_REFERENCE(x)->value)->level == 88) {
7915 cb_error_x (CB_TREE (current_statement),
7916 _("invalid use of 88 level in WHEN expression"));
7917 return NULL;
7918 }
7919
7920 /* Regular comparison */
7921 switch (flag) {
7922 case 0:
7923 /* Equal comparison */
7924 return cb_build_binary_op (s, '=', x);
7925 case 1:
7926 /* Unequal comparison */
7927 return cb_build_binary_op (s, '~', x);
7928 default:
7929 /* Class and relational conditions */
7930 return x;
7931 }
7932 }
7933
7934 static void
7935 build_evaluate (cb_tree subject_list, cb_tree case_list, cb_tree labid)
7936 {
7937 cb_tree whens, stmt;
7938 cb_tree c1, c2, c3;
7939
7940 if (case_list == NULL) {
7941 return;
7942 }
7943
7944 whens = CB_VALUE (case_list);
7945 stmt = CB_VALUE (whens);
7946 whens = CB_CHAIN (whens);
7947 c1 = NULL;
7948
7949 /* For each WHEN sequence */
7950 for (; whens; whens = CB_CHAIN (whens)) {
7951 cb_tree subjs, objs;
7952 c2 = NULL;
7953 /* Single WHEN test */
7954 for (subjs = subject_list, objs = CB_VALUE (whens);
7955 subjs && objs;
7956 subjs = CB_CHAIN (subjs), objs = CB_CHAIN (objs)) {
7957 c3 = evaluate_test (CB_VALUE (subjs), CB_VALUE (objs));
7958 if (c3 == NULL || c3 == cb_error_node) {
7959 return;
7960 }
7961
7962 if (c2 == NULL) {
7963 c2 = c3;
7964 } else {
7965 c2 = cb_build_binary_op (c2, '&', c3);
7966 if (c2 == cb_error_node) {
7967 return;
7968 }
7969 }
7970 }
7971 if (subjs || objs) {
7972 cb_error_x (whens, _("wrong number of WHEN parameters"));
7973 }
7974 /* Connect multiple WHEN's */
7975 if (c1 == NULL) {
7976 c1 = c2;
7977 } else if (c2) {
7978 c1 = cb_build_binary_op (c1, '|', c2);
7979 if (c1 == cb_error_node) {
7980 return;
7981 }
7982 }
7983 }
7984
7985 if (c1 == NULL) {
7986 int old_line = cb_source_line;
7987 const char *old_file = cb_source_file;
7988
7989 cb_source_line = stmt->source_line;
7990 cb_source_file = stmt->source_file;
7991
7992 cb_emit (cb_build_comment ("WHEN OTHER"));
7993 cb_emit (stmt);
7994
7995 cb_source_file = old_file;
7996 cb_source_line = old_line;
7997
7998 } else {
7999 c2 = stmt;
8000 /* Check if last statement is GO TO */
8001 for (c3 = stmt; c3; c3 = CB_CHAIN (c3)) {
8002 if (!CB_CHAIN(c3)) {
8003 break;
8004 }
8005 }
8006 if (c3 && CB_VALUE (c3) && CB_STATEMENT_P (CB_VALUE (c3))) {
8007 c3 = CB_STATEMENT (CB_VALUE (c3))->body;
8008 if (c3 && CB_VALUE (c3) && !CB_GOTO_P (CB_VALUE(c3))) {
8009 /* Append the jump */
8010 c2 = cb_list_add (stmt, labid);
8011 }
8012 }
8013 cb_emit (cb_build_if (cb_build_cond (c1), c2, NULL, 0));
8014 build_evaluate (subject_list, CB_CHAIN (case_list), labid);
8015 }
8016 }
8017
8018 void
8019 cb_emit_evaluate (cb_tree subject_list, cb_tree case_list)
8020 {
8021 cb_tree x;
8022 char sbuf[16];
8023
8024 snprintf (sbuf, sizeof(sbuf), "goto %s%d;", CB_PREFIX_LABEL, cb_id);
8025 x = cb_build_direct (cobc_parse_strdup (sbuf), 0);
8026 build_evaluate (subject_list, case_list, x);
8027 snprintf (sbuf, sizeof(sbuf), "%s%d:;", CB_PREFIX_LABEL, cb_id);
8028 cb_emit (cb_build_comment ("End EVALUATE"));
8029 cb_emit (cb_build_direct (cobc_parse_strdup (sbuf), 0));
8030 cb_id++;
8031 }
8032
8033 /* FREE statement */
8034
8035 void
8036 cb_emit_free (cb_tree vars)
8037 {
8038 cb_tree l;
8039 struct cb_field *f;
8040 int i;
8041
8042 if (cb_validate_list (vars)) {
8043 return;
8044 }
8045 for (l = vars, i = 1; l; l = CB_CHAIN (l), i++) {
8046 if (CB_TREE_CLASS (CB_VALUE (l)) == CB_CLASS_POINTER) {
8047 if (CB_CAST_P (CB_VALUE (l))) {
8048 f = CB_FIELD_PTR (CB_CAST (CB_VALUE(l))->val);
8049 if (!f->flag_item_based) {
8050 cb_error_x (CB_TREE (current_statement),
8051 _("target %d of FREE is not a BASED data item"), i);
8052 }
8053 cb_emit (CB_BUILD_FUNCALL_2 ("cob_free_alloc",
8054 CB_BUILD_CAST_ADDRESS (CB_VALUE (l)), NULL));
8055 } else {
8056 cb_emit (CB_BUILD_FUNCALL_2 ("cob_free_alloc",
8057 NULL, CB_BUILD_CAST_ADDRESS (CB_VALUE (l))));
8058 }
8059 } else if (CB_REF_OR_FIELD_P (CB_VALUE (l))) {
8060 f = CB_FIELD_PTR (CB_VALUE (l));
8061 if (!f->flag_item_based) {
8062 cb_error_x (CB_TREE (current_statement),
8063 _("target %d of FREE is not a BASED data item"), i);
8064 }
8065 cb_emit (CB_BUILD_FUNCALL_2 ("cob_free_alloc",
8066 CB_BUILD_CAST_ADDR_OF_ADDR (CB_VALUE (l)), NULL));
8067 } else {
8068 cb_error_x (CB_TREE (current_statement),
8069 _("target %d of FREE must be a data pointer"), i);
8070 }
8071 }
8072 }
8073
8074 /* GO TO statement */
8075
8076 void
8077 cb_emit_goto (cb_tree target, cb_tree depending)
8078 {
8079 if (target == cb_error_node) {
8080 return;
8081 }
8082 if (target == NULL) {
8083 cb_verify (cb_goto_statement_without_name, _("GO TO without procedure-name"));
8084 } else if (depending) {
8085 /* GO TO procedure-name ... DEPENDING ON identifier */
8086 if (cb_check_numeric_value (depending) == cb_error_node) {
8087 return;
8088 }
8089 cb_check_data_incompat (depending);
8090 cb_emit (cb_build_goto (target, depending));
8091 } else if (CB_CHAIN (target)) {
8092 cb_error_x (CB_TREE (current_statement),
8093 _("GO TO with multiple procedure-names"));
8094 } else {
8095 /* GO TO procedure-name */
8096 cb_emit (cb_build_goto (CB_VALUE (target), NULL));
8097 }
8098 }
8099
8100 void
8101 cb_emit_goto_entry (cb_tree target, cb_tree depending)
8102 {
8103 if (target == cb_error_node) {
8104 return;
8105 }
8106 if (depending) {
8107 /* GO TO ENTRY entry-name ... DEPENDING ON identifier */
8108 if (cb_check_numeric_value (depending) == cb_error_node) {
8109 return;
8110 }
8111 cb_check_data_incompat (depending);
8112 cb_emit (cb_build_goto (target, depending));
8113 } else if (CB_CHAIN (target)) {
8114 cb_error_x (CB_TREE (current_statement),
8115 _("GO TO ENTRY with multiple entry-names"));
8116 } else {
8117 /* GO TO ENTRY entry-name */
8118 cb_emit (cb_build_goto (CB_VALUE (target), NULL));
8119 }
8120 }
8121
8122 void
8123 cb_emit_exit (const unsigned int goback)
8124 {
8125 if (goback) {
8126 cb_emit (cb_build_goto (cb_int1, NULL));
8127 } else {
8128 cb_emit (cb_build_goto (NULL, NULL));
8129 }
8130 }
8131
8132 /* IF statement */
8133
8134 void
8135 cb_emit_if (cb_tree cond, cb_tree stmt1, cb_tree stmt2)
8136 {
8137 cb_emit (cb_build_if (cond, stmt1, stmt2, 1));
8138 }
8139
8140 /* SEARCH .. WHEN clause (internal IF statement) */
8141
8142 cb_tree
8143 cb_build_if_check_break (cb_tree cond, cb_tree stmts)
8144 {
8145 cb_tree stmt_lis;
8146
8147 stmt_lis = cb_check_needs_break (stmts);
8148 return cb_build_if (cond, stmt_lis, NULL, 0);
8149 }
8150
8151 /* INITIALIZE statement */
8152
8153 void
8154 cb_emit_initialize (cb_tree vars, cb_tree fillinit, cb_tree value,
8155 cb_tree replacing, cb_tree def)
8156 {
8157 cb_tree l;
8158 struct cb_field *f, *p;
8159 int odo_level;
8160 unsigned int no_fill_init;
8161 unsigned int def_init;
8162 cb_tree x;
8163
8164 if (cb_validate_list (vars)) {
8165 return;
8166 }
8167 if (value == NULL && replacing == NULL) {
8168 def = cb_true;
8169 }
8170 no_fill_init = (fillinit == NULL);
8171 def_init = (def != NULL);
8172 for (l = vars; l; l = CB_CHAIN (l)) {
8173 x = CB_VALUE (l);
8174 if (CB_VALID_TREE (x)
8175 && ( CB_FIELD_P (x)
8176 || (CB_REFERENCE_P (x) && CB_FIELD_P (CB_REFERENCE (x)->value)))) {
8177 /* as expected */
8178 } else {
8179 cb_error_x (CB_TREE (current_statement), _("invalid INITIALIZE statement"));
8180 return;
8181 }
8182
8183 f = CB_FIELD_PTR (x);
8184 odo_level = 0;
8185 while (f->children)
8186 f = f->children;
8187 for (p = f; p; p = p->parent) {
8188 if (p->depending) {
8189 odo_level++;
8190 }
8191 p->odo_level = odo_level;
8192 if (!p->parent) {
8193 break;
8194 }
8195 }
8196 if (CB_FIELD_PTR (x)->odo_level
8197 && CB_REFERENCE_P (x)
8198 && CB_REFERENCE (x)->subs == NULL
8199 && CB_REFERENCE (x)->length == NULL) {
8200 cb_tree temp;
8201 temp = cb_build_index (cb_build_filler (), NULL, 0, NULL);
8202 CB_FIELD (cb_ref (temp))->usage = CB_USAGE_LENGTH;
8203 CB_FIELD (cb_ref (temp))->count++;
8204 CB_FIELD (cb_ref (temp))->pic->have_sign = 0; /* LENGTH is UNSIGNED */
8205 cb_emit (cb_build_assign (temp, cb_build_length_1 (x)));
8206 CB_REFERENCE (x)->length = temp;
8207 }
8208 cb_emit (cb_build_initialize (x , value, replacing,
8209 def_init, 1, no_fill_init));
8210 }
8211 }
8212
8213 static size_t calc_reference_size (cb_tree xr)
8214 {
8215 cb_tree ref = cb_ref (xr);
8216 if (ref == cb_error_node) {
8217 return 0;
8218 }
8219 if (CB_REF_OR_FIELD_P (ref)) {
8220 struct cb_reference *r = CB_REFERENCE (xr);
8221 if (r->offset) {
8222 if (r->length) {
8223 if (CB_LITERAL_P (r->length)) {
8224 return cb_get_int (r->length);
8225 }
8226 } else {
8227 if (CB_LITERAL_P (r->offset)) {
8228 return (size_t)CB_FIELD_PTR (xr)->size
8229 - cb_get_int (r->offset) + 1;
8230 }
8231 }
8232 } else {
8233 return CB_FIELD_PTR (xr)->size;
8234 }
8235 } else if (CB_ALPHABET_NAME_P (ref)) {
8236 return 256;
8237 }
8238 return 0;
8239 }
8240
8241
8242 /* INSPECT statement */
8243
8244 static void
8245 validate_inspect (cb_tree x, cb_tree y, const unsigned int replacing_or_converting)
8246 {
8247 size_t size1;
8248 size_t size2;
8249
8250 switch (CB_TREE_TAG(x)) {
8251 case CB_TAG_REFERENCE:
8252 size1 = calc_reference_size (x);
8253 break;
8254 case CB_TAG_LITERAL:
8255 size1 = CB_LITERAL(x)->size;
8256 break;
8257 case CB_TAG_CONST:
8258 size1 = 1;
8259 break;
8260 default:
8261 size1 = 0;
8262 break;
8263 }
8264 if (size1) {
8265 switch (CB_TREE_TAG(y)) {
8266 case CB_TAG_REFERENCE:
8267 size2 = calc_reference_size (y);
8268 break;
8269 case CB_TAG_LITERAL:
8270 size2 = CB_LITERAL(y)->size;
8271 break;
8272 /* note: in case of CONST the original size is used */
8273 default:
8274 size2 = 0;
8275 break;
8276 }
8277 if (size2 && size1 != size2) {
8278 if (replacing_or_converting == 1) {
8279 cb_error_x (CB_TREE (current_statement),
8280 _("%s operands differ in size"), "REPLACING");
8281 } else {
8282 cb_error_x (CB_TREE (current_statement),
8283 _("%s operands differ in size"), "CONVERTING");
8284 }
8285 }
8286 }
8287 }
8288
8289 static void
8290 emit_invalid_target_error (const enum cb_inspect_clause clause)
8291 {
8292 const char *clause_name;
8293
8294 switch (clause) {
8295 case TALLYING_CLAUSE:
8296 clause_name = "TALLYING";
8297 break;
8298
8299 case REPLACING_CLAUSE:
8300 clause_name = "REPLACING";
8301 break;
8302
8303 case CONVERTING_CLAUSE:
8304 clause_name = "CONVERTING";
8305 break;
8306
8307 case TRANSFORM_STATEMENT:
8308 clause_name = "TRANSFORM";
8309 break;
8310
8311 /* LCOV_EXCL_START */
8312 default:
8313 cobc_err_msg (_("unexpected clause %d"), clause);
8314 COBC_ABORT ();
8315 /* LCOV_EXCL_STOP */
8316 }
8317
8318 cb_error_x (CB_TREE (current_statement), _("invalid target for %s"),
8319 clause_name);
8320 }
8321
8322 void
8323 cb_emit_inspect (cb_tree var, cb_tree body, const enum cb_inspect_clause clause)
8324 {
8325 int replacing_or_converting =
8326 clause == REPLACING_CLAUSE || clause == CONVERTING_CLAUSE;
8327 cb_tree replacing_flag = clause == REPLACING_CLAUSE ? cb_int1 : cb_int0;
8328
8329 switch (CB_TREE_TAG (var)) {
8330 case CB_TAG_REFERENCE:
8331 break;
8332 case CB_TAG_INTRINSIC:
8333 if (replacing_or_converting) {
8334 goto error;
8335 }
8336 switch (CB_TREE_CATEGORY (var)) {
8337 case CB_CATEGORY_ALPHABETIC:
8338 case CB_CATEGORY_ALPHANUMERIC:
8339 case CB_CATEGORY_NATIONAL:
8340 break;
8341 default:
8342 goto error;
8343 }
8344 break;
8345 case CB_TAG_LITERAL:
8346 if (replacing_or_converting) {
8347 goto error;
8348 }
8349 break;
8350 default:
8351 goto error;
8352 }
8353
8354 cb_emit (CB_BUILD_FUNCALL_2 ("cob_inspect_init", var, replacing_flag));
8355 cb_emit_list (body);
8356 cb_emit (CB_BUILD_FUNCALL_0 ("cob_inspect_finish"));
8357 return;
8358
8359 error:
8360 emit_invalid_target_error (clause);
8361 }
8362
8363 void
8364 cb_init_tallying (void)
8365 {
8366 inspect_func = NULL;
8367 inspect_data = NULL;
8368 }
8369
8370 cb_tree
8371 cb_build_tallying_data (cb_tree x)
8372 {
8373 inspect_data = x;
8374 return NULL;
8375 }
8376
8377 cb_tree
8378 cb_build_tallying_characters (cb_tree l)
8379 {
8380 if (inspect_data == NULL) {
8381 cb_error_x (CB_TREE (current_statement),
8382 _("data name expected before %s"), "CHARACTERS");
8383 }
8384 inspect_func = NULL;
8385 return cb_list_add (l, CB_BUILD_FUNCALL_1 ("cob_inspect_characters", inspect_data));
8386 }
8387
8388 cb_tree
8389 cb_build_tallying_all (void)
8390 {
8391 if (inspect_data == NULL) {
8392 cb_error_x (CB_TREE (current_statement),
8393 _("data name expected before %s"), "ALL");
8394 }
8395 inspect_func = "cob_inspect_all";
8396 return NULL;
8397 }
8398
8399 cb_tree
8400 cb_build_tallying_leading (void)
8401 {
8402 if (inspect_data == NULL) {
8403 cb_error_x (CB_TREE (current_statement),
8404 _("data name expected before %s"), "LEADING");
8405 }
8406 inspect_func = "cob_inspect_leading";
8407 return NULL;
8408 }
8409
8410 cb_tree
8411 cb_build_tallying_trailing (void)
8412 {
8413 if (inspect_data == NULL) {
8414 cb_error_x (CB_TREE (current_statement),
8415 _("data name expected before %s"), "TRAILING");
8416 }
8417 inspect_func = "cob_inspect_trailing";
8418 return NULL;
8419 }
8420
8421 cb_tree
8422 cb_build_tallying_value (cb_tree x, cb_tree l)
8423 {
8424 if (inspect_func == NULL) {
8425 cb_error_x (x, _("ALL, LEADING or TRAILING expected before '%s'"), cb_name (x));
8426 }
8427 return cb_list_add (l, CB_BUILD_FUNCALL_2 (inspect_func, inspect_data, x));
8428 }
8429
8430 cb_tree
8431 cb_build_replacing_characters (cb_tree x, cb_tree l)
8432 {
8433 if (CB_LITERAL_P (x) && CB_LITERAL(x)->size != 1) {
8434 cb_error_x (CB_TREE (current_statement),
8435 _("operand has wrong size"));
8436 }
8437 return cb_list_add (l, CB_BUILD_FUNCALL_1 ("cob_inspect_characters", x));
8438 }
8439
8440 cb_tree
8441 cb_build_replacing_all (cb_tree x, cb_tree y, cb_tree l)
8442 {
8443 validate_inspect (x, y, 1);
8444 return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_all", y, x));
8445 }
8446
8447 cb_tree
8448 cb_build_replacing_leading (cb_tree x, cb_tree y, cb_tree l)
8449 {
8450 validate_inspect (x, y, 1);
8451 return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_leading", y, x));
8452 }
8453
8454 cb_tree
8455 cb_build_replacing_first (cb_tree x, cb_tree y, cb_tree l)
8456 {
8457 validate_inspect (x, y, 1);
8458 return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_first", y, x));
8459 }
8460
8461 cb_tree
8462 cb_build_replacing_trailing (cb_tree x, cb_tree y, cb_tree l)
8463 {
8464 validate_inspect (x, y, 1);
8465 return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_trailing", y, x));
8466 }
8467
8468 cb_tree
8469 cb_build_converting (cb_tree x, cb_tree y, cb_tree l)
8470 {
8471 validate_inspect (x, y, 2);
8472 return cb_list_add (l, CB_BUILD_FUNCALL_2 ("cob_inspect_converting", x, y));
8473 }
8474
8475 cb_tree
8476 cb_build_inspect_region_start (void)
8477 {
8478 return CB_LIST_INIT (CB_BUILD_FUNCALL_0 ("cob_inspect_start"));
8479 }
8480
8481 /* MOVE statement */
8482
8483 static void
8484 warning_destination (const enum cb_warn_opt warning_opt, cb_tree x)
8485 {
8486 struct cb_field *f;
8487 const char *usage;
8488
8489 if (CB_REFERENCE_P(x)) {
8490 struct cb_reference *r = CB_REFERENCE (x);
8491 if (r->offset) {
8492 return;
8493 }
8494 f = CB_FIELD (r->value);
8495 x = CB_TREE (f);
8496 } else if (CB_FIELD_P(x)) {
8497 f = CB_FIELD (x);
8498 } else {
8499 cobc_err_msg (_("call to '%s' with invalid parameter '%s'"),
8500 "warning_destination", "x");
8501 cobc_err_msg (_("unexpected tree tag: %d"), (int)CB_TREE_TAG (x));
8502 COBC_ABORT ();
8503 }
8504
8505 #if 1 /* FIXME: this is wrong, should be removed and register building be
8506 adjusted, for example ACU has RETURN-CODE as SIGNED-LONG, EXTERNAL */
8507 if (f->flag_internal_register) {
8508 usage = "BINARY-LONG";
8509 } else
8510 #endif
8511 if (f->flag_real_binary) {
8512 usage = f->pic->orig;
8513 } else if (f->usage == CB_USAGE_FLOAT) {
8514 usage = "FLOAT";
8515 } else if (f->usage == CB_USAGE_DOUBLE) {
8516 usage = "DOUBLE";
8517 } else if (f->usage == CB_USAGE_LONG_DOUBLE) {
8518 usage = "FLOAT EXTENDED";
8519 } else if (f->usage == CB_USAGE_FP_BIN32) {
8520 usage = "FLOAT-BINARY-7";
8521 } else if (f->usage == CB_USAGE_FP_BIN64) {
8522 usage = "FLOAT-BINARY-16";
8523 } else if (f->usage == CB_USAGE_FP_BIN128) {
8524 usage = "FLOAT-BINARY-34";
8525 } else if (f->usage == CB_USAGE_FP_DEC64) {
8526 usage = "FLOAT-DECIMAL-16";
8527 } else if (f->usage == CB_USAGE_FP_DEC128) {
8528 usage = "FLOAT-DECIMAL-34";
8529 } else if (f->pic) {
8530 cb_note_x (warning_opt, x, _("'%s' defined here as PIC %s"),
8531 cb_name (x), f->pic->orig);
8532 return;
8533 } else {
8534 cb_note_x (warning_opt, x, _("'%s' defined here as a group of length %d"),
8535 cb_name (x), f->size);
8536 return;
8537 }
8538
8539 if (f->flag_internal_register) {
8540 cb_note_x (warning_opt, x, _("internal register '%s' defined as USAGE %s"),
8541 f->name, usage);
8542 } else {
8543 cb_note_x (warning_opt, x, _("'%s' defined here as USAGE %s"),
8544 f->name, usage);
8545 }
8546 }
8547
8548 static void
8549 move_warning (cb_tree src, cb_tree dst, const unsigned int value_flag,
8550 const enum cb_warn_opt warning_opt, const int src_flag, const char *msg)
8551 {
8552 cb_tree loc;
8553
8554 if (suppress_warn) {
8555 return;
8556 }
8557 #if 1 /* BAD hack, but works for now */
8558 if (cobc_cs_check == CB_CS_SET || !src->source_line) {
8559 #else /* old version */
8560 if (CB_LITERAL_P (src) || !src->source_line) {
8561 #endif
8562 loc = dst;
8563 } else {
8564 loc = src;
8565 }
8566 if (value_flag) {
8567 /* VALUE clause --> always warn */
8568 cb_warning_x (COBC_WARN_FILLER, loc, "%s", msg);
8569 } else {
8570 /* MOVE statement */
8571 if (cb_warn_opt_val[warning_opt] != COBC_WARN_DISABLED) {
8572 cb_warning_x (warning_opt, loc, "%s", msg);
8573 if (src_flag) {
8574 /* note: src_flag is -1 for numeric literals,
8575 contains literal size otherwise */
8576 if (!CB_LITERAL_P (src)) {
8577 warning_destination (warning_opt, src);
8578 } else if (src_flag == -1) {
8579 if (CB_LITERAL_P (src)) {
8580 cb_note_x (warning_opt, dst,
8581 _("value is %s"), CB_LITERAL (src)->data);
8582 }
8583 } else {
8584 cb_note_x (warning_opt, dst,
8585 _("value size is %d"), src_flag);
8586 }
8587 }
8588 warning_destination (warning_opt, dst);
8589 }
8590 }
8591
8592 return;
8593 }
8594
8595 static int
8596 count_pic_alphanumeric_edited (struct cb_field *field)
8597 {
8598 cob_pic_symbol *s;
8599 int count = 0;
8600
8601 /* Count number of free places in an alphanumeric edited field */
8602 for (s = field->pic->str; s->symbol != '\0'; ++s) {
8603 if (s->symbol == '9' || s->symbol == 'A' || s->symbol == 'X') {
8604 count += s->times_repeated;
8605 }
8606 }
8607 return count;
8608 }
8609
8610 /* check if data of two fields may overlap;
8611 returns:
8612 0 = no overlapping
8613 1 = possible overlapping, would need more checks for a warning
8614 2 = possible overlapping, warn
8615 3 = overlapping, warn
8616
8617 src_f, dst_f
8618 fields to be checked
8619 src, dst
8620 references, may be NULL (no subscripts/references checked)
8621
8622 */
8623 static size_t
8624 cb_check_overlapping (struct cb_field *src_f, struct cb_field *dst_f,
8625 cb_tree src, cb_tree dst)
8626 {
8627 struct cb_field *f1;
8628 struct cb_field *ff1;
8629 struct cb_field *ff2;
8630 struct cb_reference *sr;
8631 struct cb_reference *dr;
8632 int src_size;
8633 int dst_size;
8634 int src_off;
8635 int dst_off;
8636
8637 if (CB_REFERENCE_P(src)) {
8638 sr = CB_REFERENCE (src);
8639 } else {
8640 sr = NULL;
8641 }
8642
8643 if (CB_REFERENCE_P(dst)) {
8644 dr = CB_REFERENCE (dst);
8645 } else {
8646 dr = NULL;
8647 }
8648
8649 /* Check for identical field */
8650 if (src_f == dst_f) {
8651 if (!sr || !dr) {
8652 /* same fields, no information about sub/refmod,
8653 overlapping possible */
8654 return 1;
8655 }
8656 if (sr->subs) {
8657 /* same fields with subs, overlapping possible */
8658 #if 0 /* FIXME: more checks needed:
8659 1: are all subs of source and dest identical ?
8660 2: are all subs of source and dest literals with the same integer value ?
8661 */
8662 if (...) {
8663 return 2;
8664 } else {
8665 return 0;
8666 }
8667 #else
8668 /* for now: at least resolve one sub and handle when both reference a literal
8669 or a reference ...*/
8670 if (!CB_CHAIN (sr->subs)
8671 && !CB_CHAIN (dr->subs)) {
8672 if (CB_NUMERIC_LITERAL_P(CB_VALUE (sr->subs))
8673 && CB_NUMERIC_LITERAL_P(CB_VALUE (dr->subs))) {
8674 struct cb_literal *sl, *dl;
8675
8676 sl = CB_LITERAL(CB_VALUE (sr->subs));
8677 dl = CB_LITERAL(CB_VALUE (dr->subs));
8678 if (atoll((const char*)sl->data) !=
8679 atoll((const char*)dl->data)) {
8680 return 0;
8681 }
8682 } else if (CB_REFERENCE_P(CB_VALUE (sr->subs))
8683 && CB_REFERENCE_P(CB_VALUE (dr->subs))) {
8684 struct cb_reference *tsr, *tdr;
8685
8686 tsr = CB_REFERENCE(CB_VALUE (sr->subs));
8687 tdr = CB_REFERENCE(CB_VALUE (dr->subs));
8688 if (tsr->subs || tdr->subs) {
8689 return 1;
8690 } else {
8691 if (tsr->value != tdr->value) {
8692 return 1;
8693 }
8694 }
8695 } else {
8696 return 1;
8697 }
8698 } else {
8699 return 1;
8700 }
8701 #endif
8702 }
8703
8704 /* same fields, at least one without ref-mod -> overlapping */
8705 if (!sr->offset || !dr->offset) {
8706 return 3;
8707 }
8708
8709 } else {
8710
8711 /* Check basic overlapping */
8712 for (f1 = src_f->children; f1; f1 = f1->sister) {
8713 if (f1 == dst_f) {
8714 return 3;
8715 }
8716 }
8717 for (f1 = dst_f->children; f1; f1 = f1->sister) {
8718 if (f1 == src_f) {
8719 return 3;
8720 }
8721 }
8722
8723 /* Check for same parent field */
8724 #ifdef _MSC_VER
8725 #pragma warning(push)
8726 #pragma warning(disable: 6011) // cb_field_founder always returns a valid pointer
8727 #endif
8728 ff1 = cb_field_founder (src_f);
8729 ff2 = cb_field_founder (dst_f);
8730 if (ff1->redefines) {
8731 ff1 = ff1->redefines;
8732 }
8733 if (ff2->redefines) {
8734 ff2 = ff2->redefines;
8735 }
8736 if (ff1 != ff2) {
8737 /* different field founder -> no overlapping */
8738 /* if at least one of the vars can have an assignment
8739 of a different address we must return 1 */
8740 if (ff1->flag_local_storage || ff1->flag_item_based ||
8741 ff2->flag_local_storage || ff2->flag_item_based) {
8742 return 1;
8743 } else {
8744 return 0;
8745 }
8746 }
8747 }
8748 #ifdef _MSC_VER
8749 #pragma warning(pop)
8750 #endif
8751
8752 /* check if both fields are references, otherwise we can't check further */
8753 if (!sr || !dr) {
8754 /* overlapping possible as they have the same field founder */
8755 return 1;
8756 }
8757
8758 src_off = src_f->offset;
8759 dst_off = dst_f->offset;
8760
8761 /* Check for occurs */
8762 if (src_f != dst_f && (sr->subs || dr->subs)) {
8763 /* overlapping possible */
8764 #if 0 /* FIXME: more checks needed:
8765 1: if all subs are integer literals: a full offset check of both fields
8766 2: if at least one isn't an integer literal: check that all "upper" literals
8767 are either identical or numeric literals with the same integer value */
8768 if (...) {
8769 return 2;
8770 } else {
8771 return 0;
8772 }
8773 #else
8774 return 1;
8775 #endif
8776 }
8777
8778 src_size = cb_field_size (src);
8779 dst_size = cb_field_size (dst);
8780
8781 /* Adjusting offsets by reference modification */
8782 if (sr->offset) {
8783 if (src_size == FIELD_SIZE_UNKNOWN ||
8784 !CB_LITERAL_P (sr->offset)) {
8785 return 2;
8786 }
8787 src_off += cb_get_int (sr->offset) - 1;
8788 }
8789 if (dr->offset) {
8790 if (dst_size == FIELD_SIZE_UNKNOWN ||
8791 !CB_LITERAL_P (dr->offset)) {
8792 return 2;
8793 }
8794 dst_off += cb_get_int (dr->offset) - 1;
8795 }
8796
8797 if (src_size == 0 || dst_size == 0 ||
8798 cb_field_variable_size (src_f) ||
8799 cb_field_variable_size (dst_f)) {
8800 /* overlapping possible, would need more checks */
8801 return 1;
8802 }
8803
8804 if (src_off >= dst_off && src_off < (dst_off + dst_size)) {
8805 return 3;
8806 }
8807 if (src_off < dst_off && (src_off + src_size) > dst_off) {
8808 return 3;
8809 }
8810 return 0;
8811 }
8812
8813 static int
8814 is_floating_point_usage (const enum cb_usage usage)
8815 {
8816 return usage == CB_USAGE_DOUBLE
8817 || usage == CB_USAGE_FLOAT
8818 || usage == CB_USAGE_LONG_DOUBLE
8819 || usage == CB_USAGE_FP_BIN32
8820 || usage == CB_USAGE_FP_BIN64
8821 || usage == CB_USAGE_FP_BIN128
8822 || usage == CB_USAGE_FP_DEC64
8823 || usage == CB_USAGE_FP_DEC128;
8824 }
8825
8826 int
8827 validate_move (cb_tree src, cb_tree dst, const unsigned int is_value, int *move_zero)
8828 {
8829 struct cb_field *fdst;
8830 struct cb_field *fsrc;
8831 struct cb_literal *l;
8832 unsigned char *p;
8833 cb_tree loc;
8834 cob_s64_t val;
8835 size_t i;
8836 size_t is_numeric_edited;
8837 int src_scale_mod;
8838 int dst_scale_mod;
8839 int dst_size_mod;
8840 signed int size; /* -1 as special value */
8841 int m_zero;
8842 int most_significant;
8843 int least_significant;
8844
8845 loc = src->source_line ? src : dst;
8846 is_numeric_edited = 0;
8847 overlapping = 0;
8848 if (move_zero == NULL) {
8849 move_zero = &m_zero;
8850 }
8851 *move_zero = 0;
8852 if (CB_REFERENCE_P (dst)) {
8853 if (CB_ALPHABET_NAME_P(CB_REFERENCE(dst)->value)) {
8854 goto invalid;
8855 }
8856 if (CB_FILE_P(CB_REFERENCE(dst)->value)) {
8857 goto invalid;
8858 }
8859 }
8860 if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_BOOLEAN) {
8861 cb_error_x (loc, _("invalid destination for MOVE"));
8862 return -1;
8863 }
8864
8865 if (CB_TREE_CLASS (dst) == CB_CLASS_POINTER) {
8866 if (CB_TREE_CLASS (src) == CB_CLASS_POINTER) {
8867 return 0;
8868 } else {
8869 if (cb_numeric_pointer
8870 && CB_TREE_CLASS (src) == CB_CLASS_NUMERIC) {
8871 return 0;
8872 }
8873 goto invalid;
8874 }
8875 }
8876
8877 fdst = CB_FIELD_PTR (dst);
8878 switch (CB_TREE_TAG (src)) {
8879 case CB_TAG_CONST:
8880 if (src == cb_space || src == cb_low || src == cb_high || src == cb_quote) {
8881 if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC
8882 || (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC_EDITED && !is_value)
8883 || (CB_TREE_CATEGORY (dst) == CB_CATEGORY_FLOATING_EDITED && !is_value)) {
8884 if ((current_statement && strcmp (current_statement->name, "SET") == 0)
8885 || cobc_cs_check == CB_CS_SET) {
8886 goto invalid;
8887 }
8888 }
8889 }
8890
8891 if (src == cb_space) { /* error because SPACE is category alphabetic */
8892 if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC
8893 || (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC_EDITED && !is_value)
8894 || (CB_TREE_CATEGORY (dst) == CB_CATEGORY_FLOATING_EDITED && !is_value)) {
8895 /* note: ACUCOBOL and MF allow this, but not for NUMERIC + VALUE */
8896 if (is_value) {
8897 goto invalid;
8898 }
8899 if (cb_verify_x (loc, cb_move_fig_space_to_numeric,
8900 _("MOVE of figurative constant SPACE to numeric item"))) {
8901 if (cb_move_nonnumlit_to_numeric_is_zero) {
8902 goto movezero;
8903 }
8904 break;
8905 }
8906 return -1; /* error message raised already*/
8907 }
8908 } else if (src == cb_zero) {
8909 if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHABETIC) {
8910 goto invalid;
8911 }
8912 } else if (src == cb_quote) { /* remark: no error because QUOTE is category alphanumeric */
8913 if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC) {
8914 if (!cb_verify_x (loc, cb_move_fig_quote_to_numeric,
8915 _("MOVE of figurative constant QUOTE to numeric item"))) {
8916 return -1;
8917 }
8918 if (cb_move_fig_quote_to_numeric != cb_move_fig_constant_to_numeric) {
8919 if (!cb_verify_x (loc, cb_move_fig_constant_to_numeric,
8920 _("MOVE of figurative constant to numeric item"))) {
8921 return -1;
8922 }
8923 }
8924 if (cb_move_nonnumlit_to_numeric_is_zero) {
8925 goto movezero;
8926 }
8927 }
8928 } else if (src == cb_low || src == cb_high) {
8929 if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC) {
8930 if (!cb_verify_x (loc, cb_move_fig_constant_to_numeric,
8931 _("MOVE of figurative constant to numeric item"))) {
8932 return -1;
8933 }
8934 if (cb_move_nonnumlit_to_numeric_is_zero) {
8935 goto movezero;
8936 }
8937 }
8938 }
8939 break;
8940 case CB_TAG_LITERAL:
8941 l = CB_LITERAL (src);
8942 if (CB_TREE_CLASS (src) == CB_CLASS_NUMERIC) {
8943 /* Numeric literal */
8944 if (l->all) {
8945 goto invalid;
8946 }
8947 if (is_floating_point_usage (fdst->usage)) {
8948 /* TODO: add check for exponent size */
8949 break;
8950 }
8951 most_significant = -999;
8952 least_significant = 999;
8953
8954 /* Compute the most significant figure place */
8955 for (i = 0; i < l->size; i++) {
8956 if (l->data[i] != '0') {
8957 break;
8958 }
8959 }
8960 if (i != l->size) {
8961 most_significant = (int) (l->size - l->scale - i - 1);
8962 }
8963
8964 /* Compute the least significant figure place */
8965 for (i = 0; i < l->size; i++) {
8966 if (l->data[l->size - i - 1] != '0') {
8967 break;
8968 }
8969 }
8970 if (i != l->size) {
8971 least_significant = (int) (-l->scale + i);
8972 }
8973
8974 /* Value check */
8975 switch (CB_TREE_CATEGORY (dst)) {
8976 case CB_CATEGORY_ALPHANUMERIC:
8977 case CB_CATEGORY_ALPHANUMERIC_EDITED:
8978 if (is_value) {
8979 goto expect_alphanumeric;
8980 }
8981 if (l->scale == 0) {
8982 goto expect_alphanumeric;
8983 }
8984 goto non_integer_move;
8985 case CB_CATEGORY_NUMERIC_EDITED:
8986 case CB_CATEGORY_FLOATING_EDITED:
8987 if (is_value) {
8988 cb_verify_x (loc, cb_numeric_value_for_edited_item,
8989 _("numeric literal in VALUE clause of numeric-edited item"));
8990 }
8991 /* Fall-through */
8992 case CB_CATEGORY_NUMERIC:
8993 if (fdst->pic->scale < 0) {
8994 /* Check for PIC 9(n)P(m) */
8995 if (least_significant < -fdst->pic->scale) {
8996 goto value_mismatch;
8997 }
8998 } else if (fdst->pic->scale > fdst->pic->size) {
8999 /* Check for PIC P(n)9(m) */
9000 if (most_significant >= fdst->pic->size - fdst->pic->scale) {
9001 goto value_mismatch;
9002 }
9003 }
9004 break;
9005 case CB_CATEGORY_ALPHABETIC:
9006 if (is_value) {
9007 goto expect_alphanumeric;
9008 }
9009 /* Coming from codegen */
9010 if (!suppress_warn) {
9011 goto invalid;
9012 }
9013 cb_warning_x (cb_warn_additional, loc,
9014 _("numeric move to ALPHABETIC"));
9015 break;
9016 default:
9017 if (is_value) {
9018 goto expect_alphanumeric;
9019 }
9020 goto invalid;
9021 }
9022
9023 /* Sign check */
9024 if (l->sign != 0 && !fdst->pic->have_sign) {
9025 if (is_value) {
9026 cb_error_x (loc, _("data item not signed"));
9027 return -1;
9028 }
9029 cb_warning_x (cb_warn_truncate, loc, _("ignoring sign"));
9030 }
9031
9032 /* Size check */
9033 if (fdst->flag_real_binary
9034 || ( !cb_binary_truncate
9035 && fdst->pic->scale == 0
9036 && ( fdst->usage == CB_USAGE_COMP_5
9037 || fdst->usage == CB_USAGE_COMP_X
9038 || fdst->usage == CB_USAGE_COMP_N
9039 || fdst->usage == CB_USAGE_BINARY))) {
9040 p = l->data;
9041 for (i = 0; i < l->size; i++) {
9042 if (l->data[i] != '0') {
9043 p = &l->data[i];
9044 break;
9045 }
9046 }
9047 i = l->size - i;
9048 switch (fdst->size) {
9049 case 1:
9050 if (i > 18) {
9051 goto numlit_overflow;
9052 }
9053 val = cb_get_long_long (src);
9054 if (fdst->pic->have_sign) {
9055 if (val < COB_S64_C(-128) ||
9056 val > COB_S64_C(127)) {
9057 goto numlit_overflow;
9058 }
9059 } else {
9060 if (val > COB_S64_C(255)) {
9061 goto numlit_overflow;
9062 }
9063 }
9064 break;
9065 case 2:
9066 if (i > 18) {
9067 goto numlit_overflow;
9068 }
9069 val = cb_get_long_long (src);
9070 if (fdst->pic->have_sign) {
9071 if (val < COB_S64_C(-32768) ||
9072 val > COB_S64_C(32767)) {
9073 goto numlit_overflow;
9074 }
9075 } else {
9076 if (val > COB_S64_C(65535)) {
9077 goto numlit_overflow;
9078 }
9079 }
9080 break;
9081 case 3:
9082 if (i > 18) {
9083 goto numlit_overflow;
9084 }
9085 val = cb_get_long_long (src);
9086 if (fdst->pic->have_sign) {
9087 if (val < COB_S64_C(-8388608) ||
9088 val > COB_S64_C(8388607)) {
9089 goto numlit_overflow;
9090 }
9091 } else {
9092 if (val > COB_S64_C(16777215)) {
9093 goto numlit_overflow;
9094 }
9095 }
9096 break;
9097 case 4:
9098 if (i > 18) {
9099 goto numlit_overflow;
9100 }
9101 val = cb_get_long_long (src);
9102 if (fdst->pic->have_sign) {
9103 if (val < COB_S64_C(-2147483648) ||
9104 val > COB_S64_C(2147483647)) {
9105 goto numlit_overflow;
9106 }
9107 } else {
9108 if (val > COB_S64_C(4294967295)) {
9109 goto numlit_overflow;
9110 }
9111 }
9112 break;
9113 case 5:
9114 if (i > 18) {
9115 goto numlit_overflow;
9116 }
9117 val = cb_get_long_long (src);
9118 if (fdst->pic->have_sign) {
9119 if (val < COB_S64_C(-549755813888) ||
9120 val > COB_S64_C(549755813887)) {
9121 goto numlit_overflow;
9122 }
9123 } else {
9124 if (val > COB_S64_C(1099511627775)) {
9125 goto numlit_overflow;
9126 }
9127 }
9128 break;
9129 case 6:
9130 if (i > 18) {
9131 goto numlit_overflow;
9132 }
9133 val = cb_get_long_long (src);
9134 if (fdst->pic->have_sign) {
9135 if (val < COB_S64_C(-140737488355328) ||
9136 val > COB_S64_C(140737488355327)) {
9137 goto numlit_overflow;
9138 }
9139 } else {
9140 if (val > COB_S64_C(281474976710655)) {
9141 goto numlit_overflow;
9142 }
9143 }
9144 break;
9145 case 7:
9146 if (i > 18) {
9147 goto numlit_overflow;
9148 }
9149 val = cb_get_long_long (src);
9150 if (fdst->pic->have_sign) {
9151 if (val < COB_S64_C(-36028797018963968) ||
9152 val > COB_S64_C(36028797018963967)) {
9153 goto numlit_overflow;
9154 }
9155 } else {
9156 if (val > COB_S64_C(72057594037927935)) {
9157 goto numlit_overflow;
9158 }
9159 }
9160 break;
9161 default:
9162 if (fdst->pic->have_sign) {
9163 if (i < 19) {
9164 break;
9165 }
9166 if (i > 19) {
9167 goto numlit_overflow;
9168 }
9169 if (memcmp (p, l->sign ? "9223372036854775808" :
9170 "9223372036854775807",
9171 (size_t)19) > 0) {
9172 goto numlit_overflow;
9173 }
9174 } else {
9175 if (i < 20) {
9176 break;
9177 }
9178 if (i > 20) {
9179 goto numlit_overflow;
9180 }
9181 if (memcmp (p, "18446744073709551615", (size_t)20) > 0) {
9182 goto numlit_overflow;
9183 }
9184 }
9185 break;
9186 }
9187 return 0;
9188 }
9189 if (least_significant < -fdst->pic->scale) {
9190 size = -1;
9191 goto size_overflow;
9192 }
9193 if (fdst->pic->scale > 0) {
9194 size = fdst->pic->digits - fdst->pic->scale;
9195 } else {
9196 size = fdst->pic->digits;
9197 }
9198 if (most_significant >= size) {
9199 size = -1;
9200 goto size_overflow;
9201 }
9202 } else {
9203 /* Alphanumeric literal */
9204
9205 /* Value check */
9206 switch (CB_TREE_CATEGORY (dst)) {
9207 case CB_CATEGORY_ALPHABETIC:
9208 for (i = 0; i < l->size; i++) {
9209 if (!isalpha (l->data[i]) &&
9210 l->data[i] != ' ') {
9211 goto value_mismatch;
9212 }
9213 }
9214 break;
9215 case CB_CATEGORY_NUMERIC:
9216 /* TODO: add check (maybe a configuration)
9217 for numeric data in alphanumeric literal
9218 note - we did this in versions before 3.0 */
9219 for (i = 0; i < l->size; i++) {
9220 if (!isdigit (l->data[i])) {
9221 /* no check for +-,. as MF seems to not do this here */
9222 if (cb_move_nonnumlit_to_numeric_is_zero
9223 && !is_value) {
9224 goto movezero;
9225 }
9226 goto expect_numeric;
9227 }
9228 }
9229 break;
9230 case CB_CATEGORY_NUMERIC_EDITED:
9231 /* TODO: add check (maybe a configuration)
9232 for numeric data in alphanumeric literal
9233 note - we did this in versions before 3.0 */
9234 if (!is_value) {
9235 /* TODO check if the following is correct: */
9236 /* validate the value for normal MOVE as MF does*/
9237 for (i = 0; i < l->size; i++) {
9238 if (!isdigit (l->data[i])
9239 && l->data[i] != '.'
9240 && l->data[i] != ','
9241 && l->data[i] != '+'
9242 && l->data[i] != '-'
9243 && l->data[i] != ' ') {
9244 if (cb_move_nonnumlit_to_numeric_is_zero) {
9245 goto movezero;
9246 }
9247 goto expect_numeric;
9248 }
9249 }
9250 } else {
9251 /* TODO: validate the value for VALUE - needed? */
9252 }
9253 break;
9254 case CB_CATEGORY_FLOATING_EDITED:
9255 if (!is_value) {
9256 /* TODO check if the following is correct: */
9257 /* validate the value for normal MOVE as MF does*/
9258 for (i = 0; i < l->size; i++) {
9259 if (!isdigit (l->data[i])
9260 && l->data[i] != '.'
9261 && l->data[i] != ','
9262 && l->data[i] != '+'
9263 && l->data[i] != '-'
9264 && l->data[i] != 'E'
9265 && l->data[i] != ' ') {
9266 if (cb_move_nonnumlit_to_numeric_is_zero) {
9267 goto movezero;
9268 }
9269 goto expect_numeric;
9270 }
9271 }
9272 } else {
9273 /* TODO: validate the value for VALUE - needed? */
9274 }
9275 break;
9276 default:
9277 break;
9278 }
9279
9280 /* Size check */
9281 size = cb_field_size (dst);
9282 if (size > 0
9283 && l->size > 0
9284 && !fdst->flag_any_length) {
9285 /* check the real size */
9286 fdst = CB_FIELD_PTR (dst);
9287 if (fdst->flag_justified) {
9288 /* right justified: trim left */
9289 for (i = 0; i != l->size; i++) {
9290 if (l->data[i] != ' ') {
9291 break;
9292 }
9293 }
9294 i = l->size - i;
9295 } else {
9296 /* normal field: trim right */
9297 for (i = l->size - 1; i != 0; i--) {
9298 if (l->data[i] != ' ') {
9299 break;
9300 }
9301 }
9302 i++;
9303 }
9304 if ((int)i > size) {
9305 size = (signed int)i;
9306 goto size_overflow;
9307 }
9308 /* for VALUE: additional check without trim */
9309 if (is_value && l->size > (unsigned int)fdst->size) {
9310 goto value_mismatch;
9311 }
9312 }
9313 }
9314 break;
9315 case CB_TAG_FIELD:
9316 case CB_TAG_REFERENCE:
9317 if (CB_REFERENCE_P(src) &&
9318 CB_ALPHABET_NAME_P(CB_REFERENCE(src)->value)) {
9319 break;
9320 }
9321 if (CB_REFERENCE_P(src) &&
9322 CB_FILE_P(CB_REFERENCE(src)->value)) {
9323 goto invalid;
9324 }
9325 fsrc = CB_FIELD_PTR (src);
9326
9327 if (cb_move_ibm) {
9328 /* This MOVE result is exactly as on IBM, ignore overlapping */
9329 overlapping = 0;
9330 } else {
9331 /* Check basic overlapping */
9332 overlapping = cb_check_overlapping (fsrc, fdst, src, dst);
9333 switch (overlapping) {
9334 case 0:
9335 case 1:
9336 break;
9337 case 2:
9338 loc = src->source_line ? src : dst;
9339 if (!suppress_warn) {
9340 cb_warning_x(cb_warn_pos_overlap, loc,
9341 _("overlapping MOVE may occur and produce unpredictable results"));
9342 }
9343 break;
9344 case 3:
9345 loc = src->source_line ? src : dst;
9346 if (!suppress_warn) {
9347 cb_warning_x (cb_warn_overlap, loc,
9348 _("overlapping MOVE may produce unpredictable results"));
9349 }
9350 break;
9351 /* LCOV_EXCL_START */
9352 default:
9353 cobc_err_msg("unexpected overlap result: %d", (int)overlapping);
9354 COBC_ABORT();
9355 /* LCOV_EXCL_STOP */
9356 }
9357 }
9358
9359 size = cb_field_size (src);
9360 dst_size_mod = cb_field_size (dst);
9361
9362 /* Non-elementary move */
9363 if (fsrc->children || fdst->children) {
9364 if (dst_size_mod == FIELD_SIZE_UNKNOWN) {
9365 break;
9366 }
9367 if (size > dst_size_mod) {
9368 goto size_overflow_1;
9369 }
9370 break;
9371 }
9372
9373 /* Elementary move */
9374 switch (CB_TREE_CATEGORY (src)) {
9375 case CB_CATEGORY_ALPHANUMERIC:
9376 switch (CB_TREE_CATEGORY (dst)) {
9377 case CB_CATEGORY_NUMERIC:
9378 case CB_CATEGORY_NUMERIC_EDITED:
9379 if (size > (int)fdst->pic->digits) {
9380 goto size_overflow_2;
9381 }
9382 break;
9383 case CB_CATEGORY_ALPHANUMERIC_EDITED:
9384 case CB_CATEGORY_FLOATING_EDITED:
9385 if (dst_size_mod == FIELD_SIZE_UNKNOWN) {
9386 break;
9387 }
9388 if (size > count_pic_alphanumeric_edited (fdst)) {
9389 goto size_overflow_1;
9390 }
9391 break;
9392 default:
9393 if (dst_size_mod == FIELD_SIZE_UNKNOWN) {
9394 break;
9395 }
9396 if (size > fdst->size) {
9397 goto size_overflow_1;
9398 }
9399 break;
9400 }
9401 break;
9402 case CB_CATEGORY_ALPHABETIC:
9403 case CB_CATEGORY_ALPHANUMERIC_EDITED:
9404 switch (CB_TREE_CATEGORY (dst)) {
9405 case CB_CATEGORY_NUMERIC:
9406 case CB_CATEGORY_NUMERIC_EDITED:
9407 case CB_CATEGORY_FLOATING_EDITED:
9408 goto invalid;
9409 case CB_CATEGORY_ALPHANUMERIC_EDITED:
9410 if (dst_size_mod == FIELD_SIZE_UNKNOWN) {
9411 break;
9412 }
9413 if (size > count_pic_alphanumeric_edited(fdst)) {
9414 goto size_overflow_1;
9415 }
9416 break;
9417 default:
9418 if (dst_size_mod == FIELD_SIZE_UNKNOWN) {
9419 break;
9420 }
9421 if (size > fdst->size) {
9422 goto size_overflow_1;
9423 }
9424 break;
9425 }
9426 break;
9427 case CB_CATEGORY_NUMERIC:
9428 case CB_CATEGORY_NUMERIC_EDITED:
9429 case CB_CATEGORY_FLOATING_EDITED:
9430 switch (CB_TREE_CATEGORY (dst)) {
9431 case CB_CATEGORY_ALPHABETIC:
9432 goto invalid;
9433 case CB_CATEGORY_ALPHANUMERIC_EDITED:
9434 is_numeric_edited = 1;
9435 /* Drop through */
9436 case CB_CATEGORY_ALPHANUMERIC:
9437 if (!fsrc->pic) {
9438 return -1;
9439 }
9440 if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC
9441 && fsrc->pic->scale > 0) {
9442 goto non_integer_move;
9443 }
9444 if (dst_size_mod == FIELD_SIZE_UNKNOWN) {
9445 break;
9446 }
9447 if (is_numeric_edited) {
9448 dst_size_mod = count_pic_alphanumeric_edited (fdst);
9449 } else {
9450 dst_size_mod = fdst->size;
9451 }
9452 if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC
9453 && (int)fsrc->pic->digits > dst_size_mod) {
9454 goto size_overflow_2;
9455 }
9456 if (CB_TREE_CATEGORY (src) == CB_CATEGORY_NUMERIC_EDITED
9457 && fsrc->size > dst_size_mod) {
9458 goto size_overflow_1;
9459 }
9460 break;
9461 default:
9462 if (!fsrc->pic) {
9463 return -1;
9464 }
9465 if (!fdst->pic) {
9466 return -1;
9467 }
9468 src_scale_mod = fsrc->pic->scale < 0 ?
9469 0 : fsrc->pic->scale;
9470 dst_scale_mod = fdst->pic->scale < 0 ?
9471 0 : fdst->pic->scale;
9472 if (fsrc->pic->digits - src_scale_mod >
9473 fdst->pic->digits - dst_scale_mod
9474 || src_scale_mod > dst_scale_mod) {
9475 goto size_overflow_2;
9476 }
9477 break;
9478 }
9479 break;
9480 default:
9481 cb_error_x (loc, _("invalid source for MOVE"));
9482 return -1;
9483 }
9484 break;
9485 case CB_TAG_CAST:
9486 goto invalid;
9487 case CB_TAG_INTEGER:
9488 case CB_TAG_BINARY_OP:
9489 case CB_TAG_INTRINSIC:
9490 case CB_TAG_FUNCALL:
9491 /* TODO: check this */
9492 break;
9493 /* LCOV_EXCL_START */
9494 default:
9495 cobc_err_msg (_("unexpected tree tag: %d"),
9496 (int)CB_TREE_TAG (src));
9497 COBC_ABORT ();
9498 /* LCOV_EXCL_STOP */
9499 }
9500 return 0;
9501
9502 movezero:
9503 cb_warning_x (COBC_WARN_FILLER, loc,
9504 _("source is non-numeric - substituting zero"));
9505 *move_zero = 1;
9506 return 0;
9507
9508 invalid:
9509 if (is_value) {
9510 cb_error_x (loc, _("invalid VALUE clause"));
9511 } else if ((current_statement && strcmp (current_statement->name, "SET") == 0)
9512 || cobc_cs_check == CB_CS_SET) {
9513 cb_error_x (loc, _("invalid SET statement"));
9514 } else {
9515 cb_error_x (loc, _("invalid MOVE statement"));
9516 }
9517 return -1;
9518
9519 numlit_overflow:
9520 if (is_value) {
9521 cb_error_x (loc, _("invalid VALUE clause"));
9522 cb_error_x (loc, _("literal exceeds data size"));
9523 return -1;
9524 }
9525 if (!suppress_warn) {
9526 cb_warning_x (cb_warn_truncate, loc, _("numeric literal exceeds data size"));
9527 }
9528 return 0;
9529
9530 non_integer_move:
9531 if (cb_move_noninteger_to_alphanumeric == CB_ERROR) {
9532 goto invalid;
9533 }
9534 if (!suppress_warn) {
9535 cb_warning_x (COBC_WARN_FILLER, loc, _("MOVE of non-integer to alphanumeric"));
9536 }
9537 return 0;
9538
9539 expect_numeric:
9540 move_warning (src, dst, is_value, cb_warn_strict_typing, 0,
9541 _("numeric value is expected"));
9542 return 0;
9543
9544 expect_alphanumeric:
9545 move_warning (src, dst, is_value, cb_warn_strict_typing, 0,
9546 _("alphanumeric value is expected"));
9547 return 0;
9548
9549 value_mismatch:
9550 move_warning (src, dst, is_value, cb_warn_truncate, 0,
9551 _("value does not fit the picture string"));
9552 return 0;
9553
9554 size_overflow:
9555 /* note: size is -1 for numeric literals, contains literal size otherwise */
9556 move_warning (src, dst, is_value, cb_warn_truncate, size,
9557 _("value size exceeds data size"));
9558 return 0;
9559
9560 size_overflow_1:
9561 move_warning (src, dst, is_value, cb_warn_pos_truncate, 1,
9562 _("sending field larger than receiving field"));
9563 return 0;
9564
9565 size_overflow_2:
9566 move_warning (src, dst, is_value, cb_warn_pos_truncate, 1,
9567 _("some digits may be truncated"));
9568 return 0;
9569 }
9570
9571 static cb_tree
9572 cb_build_memset (cb_tree x, const int c)
9573 {
9574 if (cb_field_size (x) == 1) {
9575 return CB_BUILD_FUNCALL_2 ("$E", x, cb_int (c));
9576 }
9577 return CB_BUILD_FUNCALL_3 ("memset",
9578 CB_BUILD_CAST_ADDRESS (x),
9579 cb_int (c), CB_BUILD_CAST_LENGTH (x));
9580 }
9581
9582 static cb_tree
9583 cb_build_move_copy (cb_tree src, cb_tree dst)
9584 {
9585 int size;
9586
9587 size = cb_field_size (dst);
9588 if (size == 1) {
9589 return CB_BUILD_FUNCALL_2 ("$F", dst, src);
9590 }
9591 if (cb_move_ibm) {
9592 overlapping = 0;
9593 return CB_BUILD_FUNCALL_3 ("cob_move_ibm",
9594 CB_BUILD_CAST_ADDRESS (dst),
9595 CB_BUILD_CAST_ADDRESS (src),
9596 CB_BUILD_CAST_LENGTH (dst));
9597 } else if (overlapping
9598 || CB_FIELD_PTR (src)->storage == CB_STORAGE_LINKAGE
9599 || CB_FIELD_PTR (dst)->storage == CB_STORAGE_LINKAGE
9600 || CB_FIELD_PTR (src)->flag_item_based
9601 || CB_FIELD_PTR (dst)->flag_item_based) {
9602 overlapping = 0;
9603 return CB_BUILD_FUNCALL_3 ("memmove",
9604 CB_BUILD_CAST_ADDRESS (dst),
9605 CB_BUILD_CAST_ADDRESS (src),
9606 CB_BUILD_CAST_LENGTH (dst));
9607 } else {
9608 return CB_BUILD_FUNCALL_3 ("memcpy",
9609 CB_BUILD_CAST_ADDRESS (dst),
9610 CB_BUILD_CAST_ADDRESS (src),
9611 CB_BUILD_CAST_LENGTH (dst));
9612 }
9613 }
9614
9615 static cb_tree
9616 cb_build_move_num_zero (cb_tree x)
9617 {
9618 struct cb_field *f;
9619
9620 f = CB_FIELD_PTR (x);
9621 switch (f->usage) {
9622 case CB_USAGE_BINARY:
9623 case CB_USAGE_COMP_5:
9624 case CB_USAGE_COMP_X:
9625 case CB_USAGE_COMP_N:
9626 if (f->flag_binary_swap) {
9627 return cb_build_memset (x, 0);
9628 }
9629 switch (f->size) {
9630 #ifdef COB_NON_ALIGNED
9631 case 1:
9632 return cb_build_assign (x, cb_int0);
9633 case 2:
9634 #ifdef COB_SHORT_BORK
9635 if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
9636 (f->offset % 4 == 0)) {
9637 return cb_build_assign (x, cb_int0);
9638 }
9639 break;
9640 #endif
9641 case 4:
9642 case 8:
9643 if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
9644 (f->offset % f->size == 0)) {
9645 return cb_build_assign (x, cb_int0);
9646 }
9647 break;
9648 #else
9649 case 1:
9650 case 2:
9651 case 4:
9652 case 8:
9653 return cb_build_assign (x, cb_int0);
9654 #endif
9655 default:
9656 break;
9657 }
9658 return cb_build_memset (x, 0);
9659 case CB_USAGE_DISPLAY:
9660 if (!cb_ebcdic_sign) {
9661 return cb_build_memset (x, '0');
9662 }
9663 if (f->pic && !f->pic->have_sign) {
9664 return cb_build_memset (x, '0');
9665 }
9666 break;
9667 case CB_USAGE_PACKED:
9668 return CB_BUILD_FUNCALL_1 ("cob_set_packed_zero", x);
9669 case CB_USAGE_COMP_6:
9670 return cb_build_memset (x, 0);
9671 default:
9672 break;
9673 }
9674 return CB_BUILD_FUNCALL_2 ("cob_move", cb_zero, x);
9675 }
9676
9677 static cb_tree
9678 cb_build_move_space (cb_tree x)
9679 {
9680 switch (CB_TREE_CATEGORY (x)) {
9681 case CB_CATEGORY_NUMERIC:
9682 case CB_CATEGORY_ALPHABETIC:
9683 case CB_CATEGORY_ALPHANUMERIC:
9684 if (!CB_FIELD_PTR (x)->flag_any_length) {
9685 return cb_build_memset (x, ' ');
9686 }
9687 /* Fall through */
9688 default:
9689 return CB_BUILD_FUNCALL_2 ("cob_move", cb_space, x);
9690 }
9691 }
9692
9693 static cb_tree
9694 cb_build_move_zero (cb_tree x)
9695 {
9696 switch (CB_TREE_CATEGORY (x)) {
9697 case CB_CATEGORY_NUMERIC:
9698 if (CB_FIELD_PTR (x)->flag_blank_zero) {
9699 return cb_build_move_space (x);
9700 } else if (CB_FIELD_PTR (x)->flag_sign_separate) {
9701 return CB_BUILD_FUNCALL_2 ("cob_move", cb_zero, x);
9702 } else {
9703 return cb_build_move_num_zero (x);
9704 }
9705 case CB_CATEGORY_ALPHABETIC:
9706 case CB_CATEGORY_ALPHANUMERIC:
9707 if (!CB_FIELD_PTR (x)->flag_any_length) {
9708 return cb_build_memset (x, '0');
9709 }
9710 /* Fall through */
9711 default:
9712 return CB_BUILD_FUNCALL_2 ("cob_move", cb_zero, x);
9713 }
9714 }
9715
9716 static cb_tree
9717 cb_build_move_high (cb_tree x)
9718 {
9719 switch (CB_TREE_CATEGORY (x)) {
9720 case CB_CATEGORY_NUMERIC:
9721 case CB_CATEGORY_ALPHABETIC:
9722 case CB_CATEGORY_ALPHANUMERIC:
9723 if (CB_FIELD_PTR (x)->flag_any_length) {
9724 return CB_BUILD_FUNCALL_2 ("cob_move", cb_high, x);
9725 }
9726 if (cb_high == cb_norm_high) {
9727 return cb_build_memset (x, 255);
9728 }
9729 /* Fall through */
9730 default:
9731 return CB_BUILD_FUNCALL_2 ("cob_move", cb_high, x);
9732 }
9733 }
9734
9735 static cb_tree
9736 cb_build_move_low (cb_tree x)
9737 {
9738 switch (CB_TREE_CATEGORY (x)) {
9739 case CB_CATEGORY_NUMERIC:
9740 case CB_CATEGORY_ALPHABETIC:
9741 case CB_CATEGORY_ALPHANUMERIC:
9742 if (CB_FIELD_PTR (x)->flag_any_length) {
9743 return CB_BUILD_FUNCALL_2 ("cob_move", cb_low, x);
9744 }
9745 if (cb_low == cb_norm_low) {
9746 return cb_build_memset (x, 0);
9747 }
9748 /* Fall through */
9749 default:
9750 return CB_BUILD_FUNCALL_2 ("cob_move", cb_low, x);
9751 }
9752 }
9753
9754 static cb_tree
9755 cb_build_move_quote (cb_tree x)
9756 {
9757 switch (CB_TREE_CATEGORY (x)) {
9758 case CB_CATEGORY_NUMERIC:
9759 case CB_CATEGORY_ALPHABETIC:
9760 case CB_CATEGORY_ALPHANUMERIC:
9761 if (!CB_FIELD_PTR (x)->flag_any_length) {
9762 return cb_build_memset (x, cb_flag_apostrophe ? '\'' : '"');
9763 }
9764 /* Fall through */
9765 default:
9766 return CB_BUILD_FUNCALL_2 ("cob_move", cb_quote, x);
9767 }
9768 }
9769
9770 #ifdef COB_EBCDIC_MACHINE
9771 static void
9772 cob_put_sign_ascii (unsigned char *p)
9773 {
9774 switch (*p) {
9775 case '0':
9776 *p = (unsigned char)'p';
9777 return;
9778 case '1':
9779 *p = (unsigned char)'q';
9780 return;
9781 case '2':
9782 *p = (unsigned char)'r';
9783 return;
9784 case '3':
9785 *p = (unsigned char)'s';
9786 return;
9787 case '4':
9788 *p = (unsigned char)'t';
9789 return;
9790 case '5':
9791 *p = (unsigned char)'u';
9792 return;
9793 case '6':
9794 *p = (unsigned char)'v';
9795 return;
9796 case '7':
9797 *p = (unsigned char)'w';
9798 return;
9799 case '8':
9800 *p = (unsigned char)'x';
9801 return;
9802 case '9':
9803 *p = (unsigned char)'y';
9804 return;
9805 }
9806 }
9807 #endif
9808
9809 static void
9810 cob_put_sign_ebcdic (unsigned char *p, const int sign)
9811 {
9812 if (sign < 0) {
9813 switch (*p) {
9814 case '0':
9815 *p = (unsigned char)'}';
9816 return;
9817 case '1':
9818 *p = (unsigned char)'J';
9819 return;
9820 case '2':
9821 *p = (unsigned char)'K';
9822 return;
9823 case '3':
9824 *p = (unsigned char)'L';
9825 return;
9826 case '4':
9827 *p = (unsigned char)'M';
9828 return;
9829 case '5':
9830 *p = (unsigned char)'N';
9831 return;
9832 case '6':
9833 *p = (unsigned char)'O';
9834 return;
9835 case '7':
9836 *p = (unsigned char)'P';
9837 return;
9838 case '8':
9839 *p = (unsigned char)'Q';
9840 return;
9841 case '9':
9842 *p = (unsigned char)'R';
9843 return;
9844 default:
9845 /* What to do here */
9846 *p = (unsigned char)'}';
9847 return;
9848 }
9849 }
9850 switch (*p) {
9851 case '0':
9852 *p = (unsigned char)'{';
9853 return;
9854 case '1':
9855 *p = (unsigned char)'A';
9856 return;
9857 case '2':
9858 *p = (unsigned char)'B';
9859 return;
9860 case '3':
9861 *p = (unsigned char)'C';
9862 return;
9863 case '4':
9864 *p = (unsigned char)'D';
9865 return;
9866 case '5':
9867 *p = (unsigned char)'E';
9868 return;
9869 case '6':
9870 *p = (unsigned char)'F';
9871 return;
9872 case '7':
9873 *p = (unsigned char)'G';
9874 return;
9875 case '8':
9876 *p = (unsigned char)'H';
9877 return;
9878 case '9':
9879 *p = (unsigned char)'I';
9880 return;
9881 default:
9882 /* What to do here ? */
9883 *p = (unsigned char)'{';
9884 return;
9885 }
9886 }
9887
9888 static cb_tree
9889 cb_build_move_literal (cb_tree src, cb_tree dst)
9890 {
9891 struct cb_literal *l;
9892 struct cb_field *f;
9893 unsigned char *buff;
9894 unsigned char *p;
9895 enum cb_category cat;
9896 int i;
9897 int diff;
9898 int val;
9899 int n;
9900 unsigned char bbyte;
9901
9902 l = CB_LITERAL (src);
9903 f = CB_FIELD_PTR (dst);
9904 cat = CB_TREE_CATEGORY (dst);
9905
9906 if (f->flag_any_length) {
9907 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
9908 }
9909
9910 if (l->all) {
9911 if (cat == CB_CATEGORY_NUMERIC
9912 || cat == CB_CATEGORY_NUMERIC_EDITED
9913 || cat == CB_CATEGORY_FLOATING_EDITED) {
9914 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
9915 }
9916 if (l->size == 1) {
9917 return CB_BUILD_FUNCALL_3 ("memset",
9918 CB_BUILD_CAST_ADDRESS (dst),
9919 cb_int (l->data[0]),
9920 CB_BUILD_CAST_LENGTH (dst));
9921 }
9922 bbyte = l->data[0];
9923 for (i = 0; i < (int)l->size; i++) {
9924 if (bbyte != l->data[i]) {
9925 break;
9926 }
9927 bbyte = l->data[i];
9928 }
9929 if (i == (int)l->size) {
9930 return CB_BUILD_FUNCALL_3 ("memset",
9931 CB_BUILD_CAST_ADDRESS (dst),
9932 cb_int (l->data[0]),
9933 CB_BUILD_CAST_LENGTH (dst));
9934 }
9935 if (f->size > 128) {
9936 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
9937 }
9938 buff = cobc_parse_malloc ((size_t)f->size);
9939 for (i = 0; i < f->size; i++) {
9940 buff[i] = l->data[i % l->size];
9941 }
9942 return CB_BUILD_FUNCALL_3 ("memcpy",
9943 CB_BUILD_CAST_ADDRESS (dst),
9944 cb_build_string (buff, (size_t)f->size),
9945 CB_BUILD_CAST_LENGTH (dst));
9946 }
9947
9948 if (cat == CB_CATEGORY_NUMERIC_EDITED
9949 || cat == CB_CATEGORY_FLOATING_EDITED) {
9950 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
9951 }
9952
9953 if ((cat == CB_CATEGORY_NUMERIC && f->usage == CB_USAGE_DISPLAY
9954 && f->pic->scale == l->scale && !f->flag_sign_leading
9955 && !f->flag_sign_separate && !f->flag_blank_zero)
9956 || ((cat == CB_CATEGORY_ALPHABETIC || cat == CB_CATEGORY_ALPHANUMERIC)
9957 && f->size < (int) (l->size + 16)
9958 && !cb_field_variable_size (f))) {
9959 buff = cobc_parse_malloc ((size_t)f->size);
9960 diff = (int) (f->size - l->size);
9961 if (cat == CB_CATEGORY_NUMERIC) {
9962 if (diff <= 0) {
9963 memcpy (buff, l->data - diff, (size_t)f->size);
9964 } else {
9965 memset (buff, '0', (size_t)diff);
9966 memcpy (buff + diff, l->data, (size_t)l->size);
9967 }
9968 /* Check all zeros */
9969 n = 0;
9970 for (p = buff; p < buff + f->size; p++) {
9971 if (*p != '0') {
9972 n = 1;
9973 break;
9974 }
9975 }
9976 if (f->pic->have_sign) {
9977 p = &buff[f->size - 1];
9978 if (!n) {
9979 /* Zeros */
9980 /* EBCDIC - store sign otherwise nothing */
9981 if (cb_ebcdic_sign) {
9982 cob_put_sign_ebcdic (p, 1);
9983 }
9984 } else if (cb_ebcdic_sign) {
9985 cob_put_sign_ebcdic (p, l->sign);
9986 } else if (l->sign < 0) {
9987 #ifdef COB_EBCDIC_MACHINE
9988 cob_put_sign_ascii (p);
9989 #else
9990 *p += 0x40;
9991 #endif
9992 }
9993 }
9994 } else {
9995 if (f->flag_justified) {
9996 if (diff <= 0) {
9997 memcpy (buff, l->data - diff, (size_t)f->size);
9998 } else {
9999 memset (buff, ' ', (size_t)diff);
10000 memcpy (buff + diff, l->data, (size_t)l->size);
10001 }
10002 } else {
10003 if (diff <= 0) {
10004 memcpy (buff, l->data, (size_t)f->size);
10005 } else {
10006 memcpy (buff, l->data, (size_t)l->size);
10007 memset (buff + l->size, ' ', (size_t)diff);
10008 }
10009 }
10010 }
10011 bbyte = *buff;
10012 if (f->size == 1) {
10013 cobc_parse_free (buff);
10014 return CB_BUILD_FUNCALL_2 ("$E", dst, cb_int (bbyte));
10015 }
10016 for (i = 0; i < f->size; i++) {
10017 if (bbyte != buff[i]) {
10018 break;
10019 }
10020 }
10021 if (i == f->size) {
10022 cobc_parse_free (buff);
10023 return CB_BUILD_FUNCALL_3 ("memset",
10024 CB_BUILD_CAST_ADDRESS (dst),
10025 cb_int (bbyte),
10026 CB_BUILD_CAST_LENGTH (dst));
10027 }
10028 return CB_BUILD_FUNCALL_3 ("memcpy",
10029 CB_BUILD_CAST_ADDRESS (dst),
10030 cb_build_string (buff, (size_t)f->size),
10031 CB_BUILD_CAST_LENGTH (dst));
10032 }
10033
10034 if ((f->usage == CB_USAGE_BINARY
10035 || f->usage == CB_USAGE_COMP_5
10036 || f->usage == CB_USAGE_COMP_X
10037 || f->usage == CB_USAGE_COMP_N)
10038 && cb_fits_int (src)
10039 && f->size <= 8) {
10040 if (cb_binary_truncate) {
10041 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10042 }
10043
10044 val = cb_get_int (src);
10045 n = f->pic->scale - l->scale;
10046 if ((l->size + n) > 9) {
10047 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10048 }
10049 for (; n > 0; n--) {
10050 val *= 10;
10051 }
10052 for (; n < 0; n++) {
10053 val /= 10;
10054 }
10055 if (val == 0) {
10056 return cb_build_move_num_zero (dst);
10057 }
10058 if (val < 0 && !f->pic->have_sign) {
10059 val = -val;
10060 }
10061 if (f->size == 1) {
10062 return cb_build_assign (dst, cb_int (val));
10063 }
10064 if (f->flag_binary_swap) {
10065 i = (f->size - 1) + (8 * (f->pic->have_sign ? 1 : 0));
10066 optimize_defs[bin_set_funcs[i].optim_val] = 1;
10067 return CB_BUILD_FUNCALL_2 (bin_set_funcs[i].optim_name,
10068 CB_BUILD_CAST_ADDRESS (dst),
10069 cb_int (val));
10070 }
10071 switch (f->size) {
10072 case 2:
10073 #ifdef COB_SHORT_BORK
10074 if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
10075 (f->offset % 4 == 0)) {
10076 return cb_build_assign (dst, cb_int (val));
10077 }
10078 break;
10079 #endif
10080 case 4:
10081 case 8:
10082 #ifdef COB_NON_ALIGNED
10083 if (f->storage != CB_STORAGE_LINKAGE && f->indexes == 0 &&
10084 (f->offset % f->size == 0)) {
10085 return cb_build_assign (dst, cb_int (val));
10086 }
10087 break;
10088 #else
10089 return cb_build_assign (dst, cb_int (val));
10090 #endif
10091 default:
10092 break;
10093 }
10094 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10095 }
10096
10097 if ((f->usage == CB_USAGE_PACKED || f->usage == CB_USAGE_COMP_6) &&
10098 cb_fits_int (src)) {
10099 if (f->pic->scale < 0) {
10100 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10101 }
10102 val = cb_get_int (src);
10103 n = f->pic->scale - l->scale;
10104 if ((l->size + n) > 9) {
10105 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10106 }
10107 for (; n > 0; n--) {
10108 val *= 10;
10109 }
10110 for (; n < 0; n++) {
10111 val /= 10;
10112 }
10113 if (val == 0) {
10114 return cb_build_move_num_zero (dst);
10115 }
10116 if (val < 0 && !f->pic->have_sign) {
10117 val = -val;
10118 }
10119 #if 1 /* RXWRXW - Set packed */
10120 return CB_BUILD_FUNCALL_2 ("cob_set_packed_int", dst,
10121 cb_int (val));
10122 #else
10123 return CB_BUILD_FUNCALL_2 ("cob_set_packed_int", dst,
10124 cb_build_cast_llint (src));
10125 #endif
10126 }
10127 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10128 }
10129
10130 static cb_tree
10131 cb_build_move_field (cb_tree src, cb_tree dst)
10132 {
10133 struct cb_field *src_f;
10134 struct cb_field *dst_f;
10135 int src_size;
10136 int dst_size;
10137
10138 src_f = CB_FIELD_PTR (src);
10139 dst_f = CB_FIELD_PTR (dst);
10140
10141 if (dst_f->flag_any_length || src_f->flag_any_length) {
10142 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10143 }
10144 src_size = cb_field_size (src);
10145 dst_size = cb_field_size (dst);
10146 if (src_size > 0 && dst_size > 0 && src_size >= dst_size
10147 && !cb_field_variable_size (src_f)
10148 && !cb_field_variable_size (dst_f)) {
10149 switch (CB_TREE_CATEGORY (src)) {
10150 case CB_CATEGORY_ALPHABETIC:
10151 if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHABETIC ||
10152 CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHANUMERIC) {
10153 if (dst_f->flag_justified == 0) {
10154 return cb_build_move_copy (src, dst);
10155 }
10156 }
10157 break;
10158 case CB_CATEGORY_ALPHANUMERIC:
10159 if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHANUMERIC) {
10160 if (dst_f->flag_justified == 0) {
10161 return cb_build_move_copy (src, dst);
10162 }
10163 }
10164 break;
10165 case CB_CATEGORY_NUMERIC:
10166 if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_NUMERIC &&
10167 src_f->usage == dst_f->usage &&
10168 src_f->pic->size == dst_f->pic->size &&
10169 src_f->pic->digits == dst_f->pic->digits &&
10170 src_f->pic->scale == dst_f->pic->scale &&
10171 src_f->pic->have_sign == dst_f->pic->have_sign &&
10172 src_f->flag_binary_swap == dst_f->flag_binary_swap &&
10173 src_f->flag_sign_leading == dst_f->flag_sign_leading &&
10174 src_f->flag_sign_separate == dst_f->flag_sign_separate) {
10175 return cb_build_move_copy (src, dst);
10176 } else if (CB_TREE_CATEGORY (dst) == CB_CATEGORY_ALPHANUMERIC
10177 && src_f->usage == CB_USAGE_DISPLAY
10178 && src_f->pic->have_sign == 0
10179 && !src_f->flag_sign_leading
10180 && !src_f->flag_sign_separate) {
10181 return cb_build_move_copy (src, dst);
10182 }
10183 break;
10184 default:
10185 break;
10186 }
10187 }
10188
10189 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10190 }
10191
10192 cb_tree
10193 cb_build_move (cb_tree src, cb_tree dst)
10194 {
10195 struct cb_reference *src_ref, *dst_ref, *x;
10196 int move_zero;
10197
10198 if (CB_INVALID_TREE(src)
10199 || CB_INVALID_TREE(dst)) {
10200 return cb_error_node;
10201 }
10202
10203 if (validate_move (src, dst, 0, &move_zero) < 0) {
10204 return cb_error_node;
10205 }
10206
10207 #if 0 /* Flag receiving */
10208 if (CB_REFERENCE_P (src)) {
10209 CB_REFERENCE (src)->flag_receiving = 0;
10210 }
10211 #endif
10212 if (move_zero) {
10213 src = cb_zero;
10214 } else if (CB_LITERAL_P (src)) {
10215 /* FIXME: don't do this for a DYNAMIC LENGTH target */
10216 const struct cb_literal* lit = CB_LITERAL (src);
10217 char* p = (char*)lit->data;
10218 char* end = p + lit->size - 1;
10219 if (*end == ' ') {
10220 while (p < end && *p == ' ') p++;
10221 if (p == end) src = cb_space;
10222 }
10223 }
10224
10225 if (current_program->flag_report) {
10226 src = cb_check_sum_field (src);
10227 dst = cb_check_sum_field (dst);
10228 }
10229
10230 if (CB_REFERENCE_P (src)) {
10231 src_ref = CB_REFERENCE (src);
10232 } else {
10233 src_ref = NULL;
10234 }
10235 if (CB_REFERENCE_P (dst)) {
10236 /* Clone reference */
10237 x = cobc_parse_malloc (sizeof(struct cb_reference));
10238 *x = *CB_REFERENCE (dst);
10239 x->flag_receiving = 1;
10240 dst = CB_TREE (x);
10241 dst_ref = x;
10242 } else {
10243 dst_ref = NULL;
10244 }
10245 if (cb_listing_xref) {
10246 cobc_xref_set_receiving (dst);
10247 }
10248
10249 if (CB_TREE_CLASS (dst) == CB_CLASS_POINTER
10250 || CB_TREE_CLASS (src) == CB_CLASS_POINTER) {
10251 if (cb_numeric_pointer
10252 && CB_TREE_CLASS (dst) != CB_TREE_CLASS (src)) {
10253 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10254 }
10255 return cb_build_assign (dst, src);
10256 }
10257
10258 if (src_ref && CB_ALPHABET_NAME_P(src_ref->value)) {
10259 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10260 }
10261 if (CB_INDEX_OR_HANDLE_P (dst)) {
10262 if (src == cb_null) {
10263 return cb_build_assign (dst, cb_zero);
10264 }
10265 return cb_build_assign (dst, src);
10266 }
10267
10268 if (CB_INDEX_OR_HANDLE_P (src)) {
10269 return CB_BUILD_FUNCALL_2 ("cob_set_int", dst,
10270 cb_build_cast_int (src));
10271 }
10272
10273 if (CB_INTRINSIC_P (src) || CB_INTRINSIC_P (dst)) {
10274 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10275 }
10276
10277 if (src_ref && src_ref->check) {
10278 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10279 }
10280 if (dst_ref && dst_ref->check) {
10281 return CB_BUILD_FUNCALL_2 ("cob_move", src, dst);
10282 }
10283
10284 /* Output optimal code */
10285 if (src == cb_zero) {
10286 return cb_build_move_zero (dst);
10287 } else if (src == cb_space) {
10288 return cb_build_move_space (dst);
10289 } else if (src == cb_high) {
10290 return cb_build_move_high (dst);
10291 } else if (src == cb_low) {
10292 return cb_build_move_low (dst);
10293 } else if (src == cb_quote) {
10294 return cb_build_move_quote (dst);
10295 } else if (CB_LITERAL_P (src)) {
10296 return cb_build_move_literal (src, dst);
10297 }
10298 return cb_build_move_field (src, dst);
10299 }
10300
10301 void
10302 cb_emit_move (cb_tree src, cb_tree dsts)
10303 {
10304 cb_tree l;
10305 cb_tree x;
10306 cb_tree m;
10307 unsigned int tempval;
10308 struct cb_reference *r;
10309
10310 if (cb_validate_one (src)
10311 || cb_validate_list (dsts)) {
10312 return;
10313 }
10314
10315 cb_check_data_incompat (src);
10316 src = cb_check_sum_field (src);
10317
10318 tempval = 0;
10319 if (cb_list_length (dsts) > 1) {
10320 if (CB_REFERENCE_P (src)) {
10321 r = CB_REFERENCE (src);
10322 } else {
10323 r = NULL;
10324 }
10325 if (CB_INTRINSIC_P (src) || (r && (r->subs || r->offset))) {
10326 tempval = 1;
10327 cb_emit (CB_BUILD_FUNCALL_1 ("cob_put_indirect_field",
10328 src));
10329 }
10330 }
10331
10332 for (l = dsts; l; l = CB_CHAIN (l)) {
10333 x = CB_VALUE (l);
10334 if (CB_REFERENCE_P (x)) {
10335 r = CB_REFERENCE (x);
10336 } else {
10337 r = NULL;
10338 }
10339 if (CB_LITERAL_P (x) || CB_CONST_P (x) ||
10340 (r && (CB_LABEL_P (r->value) || CB_PROTOTYPE_P (r->value)))) {
10341 cb_error_x (CB_TREE (current_statement),
10342 _("invalid MOVE target: %s"), cb_name (x));
10343 continue;
10344 }
10345 if (!tempval) {
10346 #if 0 /* not yet merged revs 2603+2612 */
10347 if (CB_REFERENCE_P (x)
10348 && CB_REFERENCE (x)->length == NULL
10349 && cb_complex_odo) {
10350 p = CB_FIELD_PTR(x);
10351 if ((f = chk_field_variable_size (p)) != NULL) {
10352 bgnpos = -1;
10353 if (CB_REFERENCE (x)->offset == NULL
10354 || CB_REFERENCE (x)->offset == cb_int1) {
10355 bgnpos = 1;
10356 } else if (CB_REFERENCE (x)->offset == cb_int2) {
10357 bgnpos = 2;
10358 } else
10359 if (CB_REFERENCE (x)->offset != NULL
10360 && CB_LITERAL_P (CB_REFERENCE (x)->offset)) {
10361 lt = CB_LITERAL (CB_REFERENCE (x)->offset);
10362 bgnpos = atoi((const char*)lt->data);
10363 }
10364 if (bgnpos >= 1
10365 && p->storage != CB_STORAGE_LINKAGE
10366 && !p->flag_item_based
10367 && CB_LITERAL_P (src)
10368 && !cb_is_field_unbounded (p)) {
10369 CB_REFERENCE (x)->length = cb_int (p->size - bgnpos + 1);
10370 } else {
10371 if (bgnpos >= p->offset
10372 && bgnpos < f->offset
10373 && p->offset < f->offset) {
10374 /* Move for fixed size header of field */
10375 /* to move values of possible DEPENDING ON fields */
10376 svoff = CB_REFERENCE (x)->offset;
10377 CB_REFERENCE (x)->offset = cb_int (bgnpos);
10378 CB_REFERENCE (x)->length = cb_int (f->offset - p->offset - bgnpos + 1);
10379 m = cb_build_move (src, cb_check_sum_field(x));
10380 cb_emit (m);
10381 CB_REFERENCE (x)->offset = svoff;
10382 CB_REFERENCE (x)->length = NULL;
10383 /* Then move the full field with ODO lengths set */
10384 }
10385 }
10386 }
10387 }
10388 #endif
10389 #if 0 /* CHECKME: this is way to much to cater for sum field */
10390 m = cb_build_move (src, cb_check_sum_field(x));
10391 #else
10392 m = cb_build_move (src, x);
10393 #endif
10394 } else {
10395 m = CB_BUILD_FUNCALL_1 ("cob_get_indirect_field", x);
10396 }
10397 cb_emit (m);
10398 }
10399 }
10400
10401 /* OPEN statement */
10402
10403 void
10404 cb_emit_open (cb_tree file, cb_tree mode, cb_tree sharing)
10405 {
10406 cb_tree orig_file = file;
10407 struct cb_file *f;
10408 int open_mode;
10409
10410 file = cb_ref (file);
10411 if (file == cb_error_node) {
10412 return;
10413 }
10414 current_statement->file = file;
10415 f = CB_FILE (file);
10416 open_mode = CB_INTEGER(mode)->val;
10417
10418 if (cb_listing_xref
10419 && open_mode != COB_OPEN_INPUT) {
10420 /* add a "receiving" entry for the file */
10421 cobc_xref_link (&f->xref, CB_REFERENCE (orig_file)->common.source_line, 1);
10422 }
10423
10424 if (f->organization == COB_ORG_SORT) {
10425 cb_error_x (CB_TREE (current_statement),
10426 _("%s not allowed on %s files"), "OPEN", "SORT");
10427 return;
10428 } else if (f->organization == COB_ORG_LINE_SEQUENTIAL &&
10429 open_mode == COB_OPEN_I_O) {
10430 cb_error_x (CB_TREE (current_statement),
10431 _("%s not allowed on %s files"), "OPEN I-O", "LINE SEQUENTIAL");
10432 return;
10433 }
10434 if (sharing == NULL) {
10435 if (f->sharing) {
10436 sharing = f->sharing;
10437 } else {
10438 sharing = cb_int0;
10439 }
10440 }
10441
10442 /* TODO: replace mode and sharing with tree containing a string constant
10443 (defines in common.h like COB_OPEN_I_O) */
10444
10445 if (f->extfh) {
10446 cb_emit (CB_BUILD_FUNCALL_5 ("cob_extfh_open", f->extfh, file, mode,
10447 sharing, f->file_status));
10448 } else {
10449 cb_emit (CB_BUILD_FUNCALL_4 ("cob_open", file, mode,
10450 sharing, f->file_status));
10451 }
10452
10453 /* Check for file debugging */
10454 if (current_program->flag_debugging &&
10455 !current_statement->flag_in_debug &&
10456 f->flag_fl_debug) {
10457 cb_emit (cb_build_debug (cb_debug_name, f->name, NULL));
10458 cb_emit (cb_build_move (cb_space, cb_debug_contents));
10459 cb_emit (cb_build_debug_call (f->debug_section));
10460 }
10461 }
10462
10463 /* PERFORM statement */
10464
10465 void
10466 cb_emit_perform (cb_tree perform, cb_tree body, cb_tree newthread, cb_tree handle)
10467 {
10468 if (perform == cb_error_node) {
10469 return;
10470 }
10471 if (handle && !usage_is_thread_handle (handle)) {
10472 cb_error_x (handle, _("HANDLE must be either a generic or a THREAD HANDLE"));
10473 return;
10474 }
10475 if (current_program->flag_debugging &&
10476 !current_statement->flag_in_debug && body && CB_PAIR_P (body)) {
10477 cb_emit (cb_build_debug (cb_debug_contents, "PERFORM LOOP", NULL));
10478 }
10479
10480 #if 0 /* TODO: implement THREADs in libcob */
10481 /* remark: this won't work as the CALL has to be started in the new thread
10482 if (newthread) {
10483 cb_emit (CB_BUILD_FUNCALL_0 ("cob_threadstart"));
10484 }
10485 if (handle) {
10486 cb_emit (CB_BUILD_FUNCALL_1 ("cob_get_threadhandle", handle));
10487 } */
10488 #else
10489 COB_UNUSED (newthread);
10490 #endif
10491 CB_PERFORM (perform)->body = body;
10492 cb_emit (perform);
10493 }
10494
10495 cb_tree
10496 cb_build_perform_once (cb_tree body)
10497 {
10498 cb_tree x;
10499
10500 if (body == cb_error_node) {
10501 return cb_error_node;
10502 }
10503 x = cb_build_perform (CB_PERFORM_ONCE);
10504 CB_PERFORM (x)->body = body;
10505 return x;
10506 }
10507
10508 cb_tree
10509 cb_build_perform_times (cb_tree times)
10510 {
10511 cb_tree x;
10512
10513 if (cb_check_integer_value (times) == cb_error_node) {
10514 return cb_error_node;
10515 }
10516
10517 x = cb_build_perform (CB_PERFORM_TIMES);
10518 CB_PERFORM (x)->data = times;
10519 return x;
10520 }
10521
10522 cb_tree
10523 cb_build_perform_until (cb_tree condition, cb_tree varying)
10524 {
10525 cb_tree x;
10526
10527 x = cb_build_perform (CB_PERFORM_UNTIL);
10528 CB_PERFORM (x)->test = condition;
10529 CB_PERFORM (x)->varying = varying;
10530 return x;
10531 }
10532
10533 cb_tree
10534 cb_build_perform_forever (cb_tree body)
10535 {
10536 cb_tree x;
10537
10538 if (body == cb_error_node) {
10539 return cb_error_node;
10540 }
10541 x = cb_build_perform (CB_PERFORM_FOREVER);
10542 CB_PERFORM (x)->body = body;
10543 return x;
10544 }
10545
10546 cb_tree
10547 cb_build_perform_exit (struct cb_label *label)
10548 {
10549 cb_tree x;
10550
10551 x = cb_build_perform (CB_PERFORM_EXIT);
10552 CB_PERFORM (x)->data = CB_TREE (label);
10553 return x;
10554 }
10555
10556 /* READ statement */
10557
10558 void
10559 cb_emit_read (cb_tree ref, cb_tree next, cb_tree into,
10560 cb_tree key, cb_tree lock_opts)
10561 {
10562 cb_tree file;
10563 cb_tree rec;
10564 cb_tree x;
10565 struct cb_file *f;
10566 int read_opts;
10567
10568 read_opts = 0;
10569 if (lock_opts == cb_int1) {
10570 read_opts = COB_READ_LOCK;
10571 } else if (lock_opts == cb_int2) {
10572 read_opts = COB_READ_NO_LOCK;
10573 } else if (lock_opts == cb_int3) {
10574 read_opts = COB_READ_IGNORE_LOCK;
10575 } else if (lock_opts == cb_int4) {
10576 read_opts = COB_READ_WAIT_LOCK;
10577 } else if (lock_opts == cb_int5) {
10578 read_opts = COB_READ_LOCK | COB_READ_KEPT_LOCK;
10579 }
10580 file = cb_ref (ref);
10581 if (file == cb_error_node) {
10582 return;
10583 }
10584 f = CB_FILE (file);
10585
10586 rec = cb_build_field_reference (f->record, ref);
10587 if (f->organization == COB_ORG_SORT) {
10588 cb_error_x (CB_TREE (current_statement),
10589 _("%s not allowed on %s files"), "READ", "SORT");
10590 return;
10591 }
10592 if (next == cb_int1 || next == cb_int2 ||
10593 f->access_mode == COB_ACCESS_SEQUENTIAL) {
10594 /* READ NEXT/PREVIOUS */
10595 if (next == cb_int2) {
10596 switch (f->organization) {
10597 case COB_ORG_INDEXED:
10598 case COB_ORG_RELATIVE:
10599 break;
10600 default:
10601 cb_error_x (CB_TREE (current_statement),
10602 _("READ PREVIOUS not allowed for this file type"));
10603 return;
10604 }
10605 read_opts |= COB_READ_PREVIOUS;
10606 } else {
10607 read_opts |= COB_READ_NEXT;
10608 }
10609 if (key) {
10610 cb_warning (COBC_WARN_FILLER, _("KEY ignored with sequential READ"));
10611 }
10612 if (f->extfh) {
10613 cb_emit (CB_BUILD_FUNCALL_4 ("cob_extfh_read_next", f->extfh, file,
10614 f->file_status, cb_int (read_opts)));
10615 } else {
10616 cb_emit (CB_BUILD_FUNCALL_3 ("cob_read_next", file,
10617 f->file_status, cb_int (read_opts)));
10618 }
10619 } else {
10620 /* READ */
10621 /* DYNAMIC with [NOT] AT END */
10622 if (f->access_mode == COB_ACCESS_DYNAMIC &&
10623 current_statement->handler_type == AT_END_HANDLER) {
10624 read_opts |= COB_READ_NEXT;
10625 if (f->extfh) {
10626 cb_emit (CB_BUILD_FUNCALL_4 ("cob_extfh_read_next", f->extfh, file,
10627 f->file_status, cb_int (read_opts)));
10628 } else {
10629 cb_emit (CB_BUILD_FUNCALL_3 ("cob_read_next", file,
10630 f->file_status, cb_int (read_opts)));
10631 }
10632 } else if (key || f->key) {
10633 if (f->extfh) {
10634 cb_emit (CB_BUILD_FUNCALL_5 ("cob_extfh_read", f->extfh,
10635 file, key ? key : f->key,
10636 f->file_status, cb_int (read_opts)));
10637 } else {
10638 cb_emit (CB_BUILD_FUNCALL_4 ("cob_read",
10639 file, key ? key : f->key,
10640 f->file_status, cb_int (read_opts)));
10641 }
10642 } else {
10643 if (f->extfh) {
10644 cb_emit (CB_BUILD_FUNCALL_4 ("cob_extfh_read_next", f->extfh, file,
10645 f->file_status, cb_int (read_opts)));
10646 } else {
10647 cb_emit (CB_BUILD_FUNCALL_3 ("cob_read_next", file,
10648 f->file_status, cb_int (read_opts)));
10649 }
10650 }
10651 }
10652 if (into) {
10653 current_statement->handler3 = cb_build_move (rec, into);
10654 }
10655
10656 /* Check for file debugging */
10657 if (current_program->flag_debugging &&
10658 !current_statement->flag_in_debug &&
10659 f->flag_fl_debug) {
10660 if (into) {
10661 current_statement->handler3 =
10662 CB_LIST_INIT (current_statement->handler3);
10663 }
10664 x = cb_build_debug (cb_debug_name, f->name, NULL);
10665 current_statement->handler3 =
10666 cb_list_add (current_statement->handler3, x);
10667 x = cb_build_move (rec, cb_debug_contents);
10668 current_statement->handler3 =
10669 cb_list_add (current_statement->handler3, x);
10670 x = cb_build_debug_call (f->debug_section);
10671 current_statement->handler3 =
10672 cb_list_add (current_statement->handler3, x);
10673 }
10674 current_statement->file = file;
10675 }
10676
10677 /* READY TRACE statement */
10678
10679 void
10680 cb_emit_ready_trace (void)
10681 {
10682 cb_emit (CB_BUILD_FUNCALL_0 ("cob_ready_trace"));
10683 }
10684
10685
10686 /* RESET TRACE statement */
10687
10688 void
10689 cb_emit_reset_trace (void)
10690 {
10691 cb_emit (CB_BUILD_FUNCALL_0 ("cob_reset_trace"));
10692 }
10693
10694 /* REWRITE statement */
10695
10696 static int
10697 error_if_invalid_file_from_clause_literal (cb_tree literal)
10698 {
10699 enum cb_category category = CB_TREE_CATEGORY (literal);
10700
10701 if (cb_relaxed_syntax_checks || !(CB_CONST_P (literal) || CB_LITERAL_P (literal))) {
10702 return 0;
10703 }
10704
10705 if (cb_is_figurative_constant (literal)) {
10706 cb_error_x (literal, _("figurative constants not allowed in FROM clause"));
10707 return 1;
10708 }
10709
10710 if (!(category == CB_CATEGORY_ALPHANUMERIC
10711 || category == CB_CATEGORY_NATIONAL
10712 || category == CB_CATEGORY_BOOLEAN)) {
10713 cb_error_x (literal, _("literal in FROM clause must be alphanumeric, national or boolean"));
10714 return 1;
10715 }
10716
10717 return 0;
10718 }
10719
10720 void
10721 cb_emit_rewrite (cb_tree record, cb_tree from, cb_tree lockopt)
10722 {
10723 cb_tree file;
10724 cb_tree rtree;
10725 struct cb_file *f;
10726 int opts;
10727
10728 if (cb_validate_one (record)
10729 || cb_validate_one (from)) {
10730 return;
10731 }
10732 rtree = cb_ref (record);
10733 if (CB_FILE_P (rtree)) {
10734 if (from == NULL) {
10735 cb_error_x (CB_TREE (current_statement),
10736 _("%s FILE requires a FROM clause"), "REWRITE");
10737 return;
10738 }
10739 file = rtree; /* FILE filename: was used */
10740 f = CB_FILE (file);
10741 if (f->record->sister) {
10742 record = CB_TREE(f->record->sister);
10743 } else {
10744 record = CB_TREE(f->record);
10745 }
10746
10747 if (error_if_invalid_file_from_clause_literal (from)) {
10748 return;
10749 }
10750 } else {
10751 if (!CB_REF_OR_FIELD_P (rtree)) {
10752 cb_error_x (CB_TREE (current_statement),
10753 _("%s requires a record name as subject"), "REWRITE");
10754 return;
10755 }
10756 if (CB_FIELD_PTR (record)->storage != CB_STORAGE_FILE) {
10757 cb_error_x (CB_TREE (current_statement),
10758 _("%s subject does not refer to a record name"), "REWRITE");
10759 return;
10760 }
10761
10762 file = CB_TREE (CB_FIELD (rtree)->file);
10763 if (!file || file == cb_error_node) {
10764 return;
10765 }
10766 }
10767 current_statement->file = file;
10768 f = CB_FILE (file);
10769 opts = 0;
10770
10771 if (cb_listing_xref) {
10772 /* add a "receiving" entry for the file */
10773 cobc_xref_link (&f->xref, current_statement->common.source_line, 1);
10774 }
10775
10776 if (f->organization == COB_ORG_SORT) {
10777 cb_error_x (CB_TREE (current_statement),
10778 _("%s not allowed on %s files"), "REWRITE", "SORT");
10779 return;
10780 } else if (f->reports) {
10781 cb_error_x (CB_TREE (current_statement),
10782 _("%s not allowed on %s files"), "REWRITE", "REPORT");
10783 return;
10784 } else if (f->organization == COB_ORG_LINE_SEQUENTIAL) {
10785 cb_error_x (CB_TREE (current_statement),
10786 _("%s not allowed on %s files"), "REWRITE", "LINE SEQUENTIAL");
10787 return;
10788 } else if (current_statement->handler_type == INVALID_KEY_HANDLER &&
10789 (f->organization != COB_ORG_RELATIVE &&
10790 f->organization != COB_ORG_INDEXED)) {
10791 cb_error_x (CB_TREE(current_statement),
10792 _("INVALID KEY clause invalid with this file type"));
10793 return;
10794 } else if ((f->lock_mode & COB_LOCK_AUTOMATIC) && lockopt) {
10795 cb_error_x (CB_TREE (current_statement),
10796 _("LOCK clause invalid with file LOCK AUTOMATIC"));
10797 return;
10798 } else if (lockopt == cb_int1) {
10799 opts = COB_WRITE_LOCK;
10800 }
10801
10802 if (from && (!CB_FIELD_P(from) || (CB_FIELD_PTR (from) != CB_FIELD_PTR (record)))) {
10803 cb_emit (cb_build_move (from, record));
10804 }
10805
10806 /* Check debugging on record name */
10807 if (current_program->flag_debugging &&
10808 !current_statement->flag_in_debug &&
10809 CB_FIELD_PTR (record)->flag_field_debug) {
10810 cb_emit (cb_build_debug (cb_debug_name,
10811 CB_FIELD_PTR (record)->name, NULL));
10812 cb_emit (cb_build_move (record, cb_debug_contents));
10813 cb_emit (cb_build_debug_call (CB_FIELD_PTR (record)->debug_section));
10814 }
10815 if (f->extfh) {
10816 cb_emit (CB_BUILD_FUNCALL_5 ("cob_extfh_rewrite", f->extfh, file, record,
10817 cb_int (opts), f->file_status));
10818 } else {
10819 cb_emit (CB_BUILD_FUNCALL_4 ("cob_rewrite", file, record,
10820 cb_int (opts), f->file_status));
10821 }
10822 }
10823
10824 /* RELEASE statement */
10825
10826 void
10827 cb_emit_release (cb_tree record, cb_tree from)
10828 {
10829 struct cb_field *f;
10830 cb_tree file;
10831
10832 if (cb_validate_one (record)) {
10833 return;
10834 }
10835 if (cb_validate_one (from)) {
10836 return;
10837 }
10838 if (!CB_REF_OR_FIELD_P (cb_ref (record))) {
10839 cb_error_x (CB_TREE (current_statement),
10840 _("%s requires a record name as subject"), "RELEASE");
10841 return;
10842 }
10843 f = CB_FIELD_PTR (record);
10844 if (f->storage != CB_STORAGE_FILE) {
10845 cb_error_x (CB_TREE (current_statement),
10846 _("%s subject does not refer to a record name"), "RELEASE");
10847 return;
10848 }
10849 file = CB_TREE (f->file);
10850 if (CB_FILE (file)->organization != COB_ORG_SORT) {
10851 cb_error_x (CB_TREE (current_statement),
10852 _("RELEASE not allowed on this record item"));
10853 return;
10854 }
10855 current_statement->file = file;
10856 if (from) {
10857 cb_emit (cb_build_move (from, record));
10858 }
10859 cb_emit (CB_BUILD_FUNCALL_1 ("cob_file_release", file));
10860 }
10861
10862 /* RETURN statement */
10863
10864 void
10865 cb_emit_return (cb_tree ref, cb_tree into)
10866 {
10867 cb_tree file;
10868 cb_tree rec;
10869
10870 if (cb_validate_one (ref)
10871 || cb_validate_one (into)) {
10872 return;
10873 }
10874 file = cb_ref (ref);
10875 if (file == cb_error_node) {
10876 return;
10877 }
10878 rec = cb_build_field_reference (CB_FILE (file)->record, ref);
10879 cb_emit (CB_BUILD_FUNCALL_1 ("cob_file_return", file));
10880 if (into) {
10881 current_statement->handler3 = cb_build_move (rec, into);
10882 }
10883 current_statement->file = file;
10884 }
10885
10886 /* ROLLBACK statement */
10887
10888 void
10889 cb_emit_rollback (void)
10890 {
10891 cb_emit (CB_BUILD_FUNCALL_0 ("cob_rollback"));
10892 }
10893
10894 /* SEARCH statement */
10895
10896 static unsigned int
10897 search_set_keys (struct cb_field *f, cb_tree x)
10898 {
10899 struct cb_binary_op *p;
10900 struct cb_field *fldx;
10901 struct cb_field *fldy;
10902 int i;
10903
10904 if (CB_REFERENCE_P (x)) {
10905 x = build_cond_88 (x);
10906 if (!x || x == cb_error_node) {
10907 return 1;
10908 }
10909 }
10910
10911 p = CB_BINARY_OP (x);
10912 switch (p->op) {
10913 case '&':
10914 if (search_set_keys (f, p->x)) {
10915 return 1;
10916 }
10917 if (search_set_keys (f, p->y)) {
10918 return 1;
10919 }
10920 break;
10921 case '=':
10922 fldx = NULL;
10923 fldy = NULL;
10924 /* One of the operands must be a key reference */
10925 if (CB_REF_OR_FIELD_P (p->x)) {
10926 fldx = CB_FIELD_PTR (p->x);
10927 }
10928 if (CB_REF_OR_FIELD_P (p->y)) {
10929 fldy = CB_FIELD_PTR (p->y);
10930 }
10931 if (!fldx && !fldy) {
10932 cb_error_x (CB_TREE (current_statement),
10933 _("invalid SEARCH ALL condition"));
10934 return 1;
10935 }
10936
10937 for (i = 0; i < f->nkeys; ++i) {
10938 if (fldx == CB_FIELD_PTR (f->keys[i].key)) {
10939 f->keys[i].ref = p->x;
10940 f->keys[i].val = p->y;
10941 break;
10942 }
10943 }
10944 if (i == f->nkeys) {
10945 for (i = 0; i < f->nkeys; ++i) {
10946 if (fldy == CB_FIELD_PTR (f->keys[i].key)) {
10947 f->keys[i].ref = p->y;
10948 f->keys[i].val = p->x;
10949 break;
10950 }
10951 }
10952 if (i == f->nkeys) {
10953 cb_error_x (CB_TREE (current_statement),
10954 _("invalid SEARCH ALL condition"));
10955 return 1;
10956 }
10957 }
10958 break;
10959 default:
10960 cb_error_x (CB_TREE (current_statement),
10961 _("invalid SEARCH ALL condition"));
10962 return 1;
10963 }
10964 return 0;
10965 }
10966
10967 static cb_tree
10968 cb_build_search_all (cb_tree table, cb_tree cond)
10969 {
10970 cb_tree c1;
10971 cb_tree c2;
10972 struct cb_field *f;
10973 int i;
10974
10975 f = CB_FIELD_PTR (table);
10976 /* Set keys */
10977 for (i = 0; i < f->nkeys; i++) {
10978 f->keys[i].ref = NULL;
10979 }
10980 if (search_set_keys (f, cond)) {
10981 return NULL;
10982 }
10983 c1 = NULL;
10984
10985 /* Build condition */
10986 for (i = 0; i < f->nkeys; i++) {
10987 if (f->keys[i].ref) {
10988 if (f->keys[i].dir == COB_ASCENDING) {
10989 c2 = cb_build_binary_op (f->keys[i].ref, '=',
10990 f->keys[i].val);
10991 } else {
10992 c2 = cb_build_binary_op (f->keys[i].val, '=',
10993 f->keys[i].ref);
10994 }
10995 if (c1 == NULL) {
10996 c1 = c2;
10997 } else {
10998 c1 = cb_build_binary_op (c1, '&', c2);
10999 }
11000 }
11001 }
11002
11003 if (!c1) {
11004 return NULL;
11005 }
11006 return cb_build_cond (c1);
11007 }
11008
11009 void
11010 cb_emit_search (cb_tree table, cb_tree varying, cb_tree at_end, cb_tree whens)
11011 {
11012 if (cb_validate_one (table)
11013 || cb_validate_one (varying)
11014 || whens == cb_error_node) {
11015 return;
11016 }
11017 whens = cb_list_reverse (whens);
11018 cb_emit (cb_build_search (0, table, varying,
11019 cb_check_needs_break (at_end), whens));
11020 }
11021
11022 void
11023 cb_emit_search_all (cb_tree table, cb_tree at_end, cb_tree when, cb_tree stmts)
11024 {
11025 cb_tree x;
11026 cb_tree stmt_lis;
11027
11028 if (cb_validate_one (table)
11029 || when == cb_error_node) {
11030 return;
11031 }
11032 x = cb_build_search_all (table, when);
11033 if (!x) {
11034 return;
11035 }
11036
11037 stmt_lis = cb_check_needs_break (stmts);
11038 cb_emit (cb_build_search (1, table, NULL,
11039 cb_check_needs_break (at_end),
11040 cb_build_if (x, stmt_lis, NULL, 0)));
11041 }
11042
11043 /* SET statement */
11044
11045 void
11046 cb_emit_setenv (cb_tree x, cb_tree y)
11047 {
11048 cb_emit (CB_BUILD_FUNCALL_2 ("cob_set_environment", x, y));
11049 }
11050
11051 void
11052 cb_emit_set_to (cb_tree vars, cb_tree x)
11053 {
11054 cb_tree l;
11055 cb_tree v;
11056 cb_tree rtree;
11057 struct cb_cast *p;
11058 enum cb_class tree_class;
11059
11060 if (cb_validate_one (x)
11061 || cb_validate_list (vars)) {
11062 return;
11063 }
11064
11065 /* Check PROGRAM-POINTERs are the target for SET ... TO ENTRY. */
11066 if (CB_CAST_P (x)) {
11067 p = CB_CAST (x);
11068 if (p->cast_type == CB_CAST_PROGRAM_POINTER) {
11069 for (l = vars; l; l = CB_CHAIN (l)) {
11070 v = CB_VALUE (l);
11071 if (!CB_REFERENCE_P (v)) {
11072 cb_error_x (CB_TREE (current_statement),
11073 _("SET targets must be PROGRAM-POINTER"));
11074 CB_VALUE (l) = cb_error_node;
11075 } else if (CB_FIELD(cb_ref(v))->usage != CB_USAGE_PROGRAM_POINTER) {
11076 cb_error_x (CB_TREE (current_statement),
11077 _("SET targets must be PROGRAM-POINTER"));
11078 CB_VALUE (l) = cb_error_node;
11079 }
11080 }
11081 }
11082 }
11083
11084 /* Check ADDRESS OF targets can be modified. */
11085 for (l = vars; l; l = CB_CHAIN (l)) {
11086 v = CB_VALUE (l);
11087 if (!CB_CAST_P (v)) {
11088 continue;
11089 }
11090 p = CB_CAST (v);
11091 if (p->cast_type != CB_CAST_ADDRESS) {
11092 continue;
11093 }
11094 rtree = cb_ref (p->val);
11095 /* LCOV_EXCL_START */
11096 if (rtree == cb_error_node) {
11097 cobc_err_msg (_("call to '%s' with invalid parameter '%s'"),
11098 "cb_emit_set_to", "vars");
11099 COBC_ABORT ();
11100 }
11101 /* LCOV_EXCL_STOP */
11102 if (CB_FIELD (rtree)->level != 1
11103 && CB_FIELD (rtree)->level != 77) {
11104 cb_error_x (p->val, _("cannot change address of '%s', which is not level 1 or 77"),
11105 cb_name (p->val));
11106 CB_VALUE (l) = cb_error_node;
11107 } else if (!CB_FIELD (rtree)->flag_base) {
11108 cb_error_x (p->val, _("cannot change address of '%s', which is not BASED or a LINKAGE item"),
11109 cb_name (p->val));
11110 CB_VALUE (l) = cb_error_node;
11111 }
11112 }
11113
11114 /* Emit statements if targets have the correct class. */
11115 for (l = vars; l; l = CB_CHAIN (l)) {
11116 tree_class = cb_tree_class (CB_VALUE (l));
11117 switch (tree_class) {
11118 case CB_CLASS_INDEX:
11119 case CB_CLASS_NUMERIC:
11120 case CB_CLASS_POINTER:
11121 cb_check_data_incompat (x);
11122 cb_emit (cb_build_move (x, CB_VALUE (l)));
11123 break;
11124 default:
11125 if (CB_VALUE (l) != cb_error_node) {
11126 cb_error_x (CB_TREE (current_statement),
11127 _("SET target '%s' is not numeric, an INDEX or a POINTER"),
11128 cb_name (CB_VALUE(l)));
11129 }
11130 break;
11131 }
11132 }
11133 }
11134
11135 void
11136 cb_emit_set_up_down (cb_tree l, cb_tree flag, cb_tree x)
11137 {
11138 if (cb_validate_one (x)
11139 || cb_validate_list (l)) {
11140 return;
11141 }
11142 for (; l; l = CB_CHAIN (l)) {
11143 if (flag == cb_int0) {
11144 cb_emit (cb_build_add (CB_VALUE (l), x, cb_int0));
11145 } else {
11146 cb_emit (cb_build_sub (CB_VALUE (l), x, cb_int0));
11147 }
11148 }
11149 }
11150
11151 void
11152 cb_emit_set_on_off (cb_tree l, cb_tree flag)
11153 {
11154 struct cb_system_name *s;
11155
11156 if (cb_validate_list (l)) {
11157 return;
11158 }
11159 for (; l; l = CB_CHAIN (l)) {
11160 s = CB_SYSTEM_NAME (cb_ref (CB_VALUE (l)));
11161 cb_emit (CB_BUILD_FUNCALL_2 ("cob_set_switch",
11162 cb_int (s->token), flag));
11163 }
11164 }
11165
11166 void
11167 cb_emit_set_true (cb_tree l)
11168 {
11169 cb_tree x;
11170 struct cb_field *f;
11171 cb_tree ref;
11172 cb_tree val;
11173
11174 for (; l; l = CB_CHAIN (l)) {
11175 x = CB_VALUE (l);
11176 if (x == cb_error_node) {
11177 return;
11178 }
11179 if (!(CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value)) &&
11180 !CB_FIELD_P (x)) {
11181 cb_error_x (x, _("invalid SET statement"));
11182 return;
11183 }
11184 f = CB_FIELD_PTR (x);
11185 if (f->level != 88) {
11186 cb_error_x (x, _("invalid SET statement"));
11187 return;
11188 }
11189 ref = cb_build_field_reference (f->parent, x);
11190 val = CB_VALUE (f->values);
11191 if (CB_PAIR_P (val)) {
11192 val = CB_PAIR_X (val);
11193 }
11194 cb_emit (cb_build_move (val, ref));
11195 }
11196 }
11197
11198 void
11199 cb_emit_set_false (cb_tree l)
11200 {
11201 cb_tree x;
11202 struct cb_field *f;
11203 cb_tree ref;
11204 cb_tree val;
11205
11206 for (; l; l = CB_CHAIN (l)) {
11207 x = CB_VALUE (l);
11208 if (x == cb_error_node) {
11209 return;
11210 }
11211 if (!(CB_REFERENCE_P (x) && CB_FIELD_P(CB_REFERENCE(x)->value)) &&
11212 !CB_FIELD_P (x)) {
11213 cb_error_x (x, _("invalid SET statement"));
11214 return;
11215 }
11216 f = CB_FIELD_PTR (x);
11217 if (f->level != 88) {
11218 cb_error_x (x, _("invalid SET statement"));
11219 return;
11220 }
11221 if (!f->false_88) {
11222 cb_error_x (x, _("field does not have a FALSE clause"));
11223 return;
11224 }
11225 ref = cb_build_field_reference (f->parent, x);
11226 val = CB_VALUE (f->false_88);
11227 if (CB_PAIR_P (val)) {
11228 val = CB_PAIR_X (val);
11229 }
11230 cb_emit (cb_build_move (val, ref));
11231 }
11232 }
11233
11234 void
11235 cb_emit_set_thread_priority (cb_tree handle, cb_tree priority)
11236 {
11237 cb_tree used_handle;
11238
11239 if (handle && handle != cb_null && !usage_is_thread_handle (handle)) {
11240 cb_error_x (handle, _("HANDLE must be either a generic or a THREAD HANDLE"));
11241 return;
11242 }
11243 used_handle = handle;
11244 if (used_handle && used_handle == cb_null) {
11245 used_handle = CB_BUILD_FUNCALL_1 ("cob_get_threadhandle", NULL);
11246 }
11247
11248 if (cb_validate_one (priority)) {
11249 return;
11250 }
11251 if (CB_LITERAL_P (priority)) {
11252 if (cb_get_int (priority) > 32767) {
11253 cb_error (_("THREAD-priority must be between 1 and 32767"));
11254 }
11255 }
11256 #if 0 /* TODO: implement THREADs in libcob */
11257 cb_emit (CB_BUILD_FUNCALL_2 ("set_thread_priority",
11258 used_handle, cb_build_cast_int (priority)));
11259 #endif
11260 }
11261
11262 void
11263 cb_emit_set_attribute (cb_tree x, const cob_flags_t val_on,
11264 const cob_flags_t val_off)
11265 {
11266 struct cb_field *f;
11267
11268 if (cb_validate_one (x)) {
11269 return;
11270 }
11271 if (!CB_REF_OR_FIELD_P (cb_ref (x))) {
11272 cb_error_x (CB_TREE (current_statement),
11273 _("SET ATTRIBUTE requires a screen item as subject"));
11274 return;
11275 }
11276 f = CB_FIELD_PTR (x);
11277 if (f->storage != CB_STORAGE_SCREEN) {
11278 cb_error_x (CB_TREE (current_statement),
11279 _("SET ATTRIBUTE subject does not refer to a screen item"));
11280 return;
11281 }
11282 cb_emit (cb_build_set_attribute (f, val_on, val_off));
11283 }
11284
11285 void
11286 cb_emit_set_last_exception_to_off (void)
11287 {
11288 cb_emit (CB_BUILD_FUNCALL_1 ("cob_set_exception", cb_int0));
11289 }
11290
11291 /* SORT statement */
11292
11293 void
11294 cb_emit_sort_init (cb_tree name, cb_tree keys, cb_tree col, cb_tree nat_col)
11295 {
11296 cb_tree l;
11297 cb_tree rtree;
11298 struct cb_field *f;
11299
11300 if (cb_validate_list (keys)) {
11301 return;
11302 }
11303 rtree = cb_ref (name);
11304 if (rtree == cb_error_node) {
11305 return;
11306 }
11307 for (l = keys; l; l = CB_CHAIN (l)) {
11308 if (CB_VALUE (l) == NULL) {
11309 CB_VALUE (l) = name;
11310 }
11311 }
11312
11313 /* note: the reference to the program's collation,
11314 if not explicit specified in SORT is done within libcob */
11315 if (col == NULL) {
11316 col = cb_null;
11317 } else {
11318 col = cb_ref (col);
11319 }
11320 if (nat_col == NULL) {
11321 nat_col = cb_null;
11322 } else {
11323 nat_col = cb_ref (nat_col);
11324 }
11325 /* TODO: pass national collation to libcob */
11326 COB_UNUSED (nat_col);
11327
11328 if (CB_FILE_P (rtree)) {
11329 if (CB_FILE (rtree)->organization != COB_ORG_SORT) {
11330 cb_error_x (name, _("invalid SORT filename"));
11331 }
11332 if (current_program->cb_sort_return) {
11333 CB_FIELD_PTR (current_program->cb_sort_return)->count++;
11334 cb_emit (CB_BUILD_FUNCALL_5 ("cob_file_sort_init", rtree,
11335 cb_int ((int)cb_list_length (keys)), col,
11336 CB_BUILD_CAST_ADDRESS (current_program->cb_sort_return),
11337 CB_FILE(rtree)->file_status));
11338 } else {
11339 cb_emit (CB_BUILD_FUNCALL_5 ("cob_file_sort_init", rtree,
11340 cb_int ((int)cb_list_length (keys)), col,
11341 cb_null, CB_FILE(rtree)->file_status));
11342
11343 }
11344 /* TODO: pass key-specific collation to libcob */
11345 for (l = keys; l; l = CB_CHAIN (l)) {
11346 cb_emit (CB_BUILD_FUNCALL_4 ("cob_file_sort_init_key",
11347 rtree,
11348 CB_VALUE (l),
11349 CB_PURPOSE (l),
11350 cb_int (CB_FIELD_PTR (CB_VALUE(l))->offset)));
11351 }
11352 } else {
11353 cb_emit (CB_BUILD_FUNCALL_2 ("cob_table_sort_init",
11354 cb_int ((int)cb_list_length (keys)), col));
11355 /* TODO: pass key-specific collation to libcob */
11356 for (l = keys; l; l = CB_CHAIN (l)) {
11357 cb_emit (CB_BUILD_FUNCALL_3 ("cob_table_sort_init_key",
11358 CB_VALUE (l),
11359 CB_PURPOSE (l),
11360 cb_int(CB_FIELD_PTR (CB_VALUE(l))->offset
11361 - CB_FIELD_PTR (CB_VALUE(l))->parent->offset)));
11362 }
11363 f = CB_FIELD (rtree);
11364 cb_emit (CB_BUILD_FUNCALL_2 ("cob_table_sort", name,
11365 (f->depending
11366 ? cb_build_cast_int (f->depending)
11367 : cb_int (f->occurs_max))));
11368 }
11369 }
11370
11371 void
11372 cb_emit_sort_using (cb_tree file, cb_tree l)
11373 {
11374 cb_tree rtree;
11375
11376 if (cb_validate_list (l)) {
11377 return;
11378 }
11379 rtree = cb_ref (file);
11380 /* LCOV_EXCL_START */
11381 if (rtree == cb_error_node) {
11382 cobc_err_msg (_("call to '%s' with invalid parameter '%s'"),
11383 "cb_emit_sort_using", "file");
11384 COBC_ABORT ();
11385 }
11386 /* LCOV_EXCL_STOP */
11387 for (; l; l = CB_CHAIN (l)) {
11388 if (CB_FILE (cb_ref(CB_VALUE(l)))->organization == COB_ORG_SORT) {
11389 cb_error_x (CB_TREE (current_statement),
11390 _("invalid SORT USING parameter"));
11391 }
11392 cb_emit (CB_BUILD_FUNCALL_2 ("cob_file_sort_using",
11393 rtree, cb_ref (CB_VALUE (l))));
11394 }
11395 }
11396
11397 void
11398 cb_emit_sort_input (cb_tree proc)
11399 {
11400 if (current_program->flag_debugging &&
11401 !current_statement->flag_in_debug) {
11402 cb_emit (cb_build_debug (cb_debug_contents, "SORT INPUT", NULL));
11403 }
11404 cb_emit (cb_build_perform_once (proc));
11405 }
11406
11407 void
11408 cb_emit_sort_giving (cb_tree file, cb_tree l)
11409 {
11410 cb_tree p;
11411 int listlen;
11412
11413 if (cb_validate_list (l)) {
11414 return;
11415 }
11416 for (p = l; p; p = CB_CHAIN (p)) {
11417 if (CB_FILE (cb_ref(CB_VALUE(p)))->organization == COB_ORG_SORT) {
11418 cb_error_x (CB_TREE (current_statement),
11419 _("invalid SORT GIVING parameter"));
11420 }
11421 }
11422 p = cb_ref (file);
11423 /* LCOV_EXCL_START */
11424 if (p == cb_error_node) {
11425 cobc_err_msg (_("call to '%s' with invalid parameter '%s'"),
11426 "cb_emit_sort_giving", "file");
11427 COBC_ABORT ();
11428 }
11429 /* LCOV_EXCL_STOP */
11430 listlen = cb_list_length (l);
11431 p = CB_BUILD_FUNCALL_2 ("cob_file_sort_giving", p, l);
11432 CB_FUNCALL(p)->varcnt = listlen;
11433 cb_emit (p);
11434 }
11435
11436 void
11437 cb_emit_sort_output (cb_tree proc)
11438 {
11439 if (current_program->flag_debugging &&
11440 !current_statement->flag_in_debug) {
11441 if (current_statement->flag_merge) {
11442 cb_emit (cb_build_debug (cb_debug_contents,
11443 "MERGE OUTPUT", NULL));
11444 } else {
11445 cb_emit (cb_build_debug (cb_debug_contents,
11446 "SORT OUTPUT", NULL));
11447 }
11448 }
11449 cb_emit (cb_build_perform_once (proc));
11450 }
11451
11452 void
11453 cb_emit_sort_finish (cb_tree file)
11454 {
11455 if (CB_FILE_P (cb_ref (file))) {
11456 cb_emit (CB_BUILD_FUNCALL_1 ("cob_file_sort_close", cb_ref (file)));
11457 }
11458 }
11459
11460 /* START statement */
11461
11462 static unsigned int
11463 check_valid_key (const struct cb_file *cbf, const struct cb_field *f)
11464 {
11465 cb_tree kfld;
11466 struct cb_alt_key *cbak;
11467 struct cb_field *f1;
11468 struct cb_field *ff;
11469
11470 if (cbf->organization != COB_ORG_INDEXED) {
11471 if (CB_FIELD_PTR (cbf->key) != f) {
11472 cb_error_x (CB_TREE (current_statement),
11473 _("invalid key item"));
11474 return 1;
11475 }
11476 return 0;
11477 }
11478
11479 /*
11480 * Pass if field f refs a declared key for target file.
11481 * This will pass split-keys which are virtual record fields.
11482 */
11483 for (cbak = cbf->alt_key_list; cbak; cbak = cbak->next) {
11484 if (CB_FIELD_PTR (cbak->key) == f) {
11485 return 0;
11486 }
11487 }
11488 if (cbf->component_list != NULL
11489 && CB_FIELD_PTR (cbf->key) == f) {
11490 return 0;
11491 }
11492
11493 ff = cb_field_founder (f);
11494 for (f1 = cbf->record; f1; f1 = f1->sister) {
11495 if (f1 == ff) {
11496 break;
11497 }
11498 }
11499 if (!f1) {
11500 cb_error_x (CB_TREE (current_statement), _("invalid key item"));
11501 return 1;
11502 }
11503
11504 kfld = cb_ref (cbf->key);
11505 if (kfld == cb_error_node) {
11506 return 1;
11507 }
11508 if (f->offset == CB_FIELD_PTR (kfld)->offset) {
11509 return 0;
11510 }
11511 for (cbak = cbf->alt_key_list; cbak; cbak = cbak->next) {
11512 kfld = cb_ref (cbak->key);
11513 if (kfld == cb_error_node) {
11514 return 1;
11515 }
11516 if (f->offset == CB_FIELD_PTR (kfld)->offset) {
11517 return 0;
11518 }
11519 }
11520 cb_error_x (CB_TREE (current_statement), _("invalid key item"));
11521 return 1;
11522 }
11523
11524 void
11525 cb_emit_start (cb_tree file, cb_tree op, cb_tree key, cb_tree keylen)
11526 {
11527 cb_tree kfld;
11528 cb_tree fl;
11529 cb_tree cbtkey;
11530 struct cb_file *f;
11531
11532 if (cb_validate_one (key)
11533 || cb_validate_one (keylen)) {
11534 return;
11535 }
11536 fl = cb_ref (file);
11537 if (fl == cb_error_node) {
11538 return;
11539 }
11540 f = CB_FILE (fl);
11541
11542 if (f->organization != COB_ORG_INDEXED &&
11543 f->organization != COB_ORG_RELATIVE) {
11544 cb_error_x (CB_TREE (current_statement),
11545 _("%s not allowed on %s files"), "START", "SEQUENTIAL");
11546 return;
11547 }
11548 if (keylen && f->organization != COB_ORG_INDEXED) {
11549 cb_error_x (CB_TREE (current_statement),
11550 _("LENGTH/SIZE clause only allowed on INDEXED files"));
11551 return;
11552 }
11553 if (f->access_mode == COB_ACCESS_RANDOM) {
11554 cb_error_x (CB_TREE (current_statement),
11555 _("START not allowed with ACCESS MODE RANDOM"));
11556 return;
11557 }
11558
11559 current_statement->file = fl;
11560 if (key) {
11561 kfld = cb_ref (key);
11562 if (kfld == cb_error_node) {
11563 return;
11564 }
11565 if (check_valid_key (f, CB_FIELD_PTR (kfld))) {
11566 return;
11567 }
11568 cbtkey = key;
11569 } else {
11570 cbtkey = f->key;
11571 }
11572
11573 /* Check for file debugging */
11574 if (current_program->flag_debugging &&
11575 !current_statement->flag_in_debug &&
11576 f->flag_fl_debug) {
11577 /* Gen callback after start but before exception test */
11578 current_statement->flag_callback = 1;
11579 }
11580
11581 if (f->extfh) {
11582 cb_emit (CB_BUILD_FUNCALL_6 ("cob_extfh_start", f->extfh, fl, op, cbtkey, keylen,
11583 f->file_status));
11584 } else {
11585 cb_emit (CB_BUILD_FUNCALL_5 ("cob_start", fl, op, cbtkey, keylen,
11586 f->file_status));
11587 }
11588 }
11589
11590 /* STOP statement */
11591
11592 void
11593 cb_emit_stop_run (cb_tree x)
11594 {
11595 cb_emit (CB_BUILD_FUNCALL_1 ("cob_stop_run", cb_build_cast_int (x)));
11596 }
11597
11598 void
11599 cb_emit_stop_thread (cb_tree handle)
11600 {
11601 cb_tree used_handle;
11602
11603 if (handle && handle != cb_null && !usage_is_thread_handle (handle)) {
11604 cb_error_x (handle, _("HANDLE must be either a generic or a THREAD HANDLE"));
11605 return;
11606 }
11607 used_handle = handle;
11608 if (used_handle && used_handle == cb_null) {
11609 used_handle = CB_BUILD_FUNCALL_1 ("cob_get_threadhandle", NULL);
11610 }
11611 #if 0 /* TODO: implement THREADs in libcob */
11612 cb_emit (CB_BUILD_FUNCALL_1 ("cob_stop_thread", used_handle));
11613 #else
11614 cb_emit (CB_BUILD_FUNCALL_1 ("cob_stop_run", cb_int (0)));
11615 #endif
11616 }
11617
11618 /* STRING statement */
11619
11620 static int
11621 error_if_not_int_field_or_has_pic_p (const char *clause, cb_tree f)
11622 {
11623 int error = 0;
11624 enum cb_usage usage;
11625 int scale;
11626
11627 if (!f) {
11628 return 0;
11629 }
11630
11631 if (cb_validate_one (f)) {
11632 return 1;
11633 }
11634
11635 usage = CB_FIELD_PTR (f)->usage;
11636 if (CB_TREE_CATEGORY (f) != CB_CATEGORY_NUMERIC
11637 || is_floating_point_usage (usage)) {
11638 cb_error_x (f, _("%s item '%s' must be numeric and an integer"),
11639 clause, CB_NAME (f));
11640 error = 1;
11641 } else if (CB_FIELD_PTR (f)->pic) {
11642 scale = CB_FIELD_PTR (f)->pic->scale;
11643 if (scale > 0) {
11644 cb_error_x (f, _("%s item '%s' must be an integer"),
11645 clause, CB_NAME (f));
11646 error = 1;
11647 } else if (scale < 0) {
11648 cb_error_x (f, _("%s item '%s' may not have PICTURE with P in it"),
11649 clause, CB_NAME (f));
11650 error = 1;
11651 }
11652 }
11653
11654 return error;
11655 }
11656
11657 /* Validate POINTER clause for STRING and UNSTRING */
11658 static void
11659 validate_pointer_clause (cb_tree pointer, cb_tree pointee)
11660 {
11661 struct cb_field *pointer_field = CB_FIELD_PTR (pointer);
11662
11663 if (pointer_field->children) {
11664 cb_error_x (pointee, _("'%s' is not an elementary item"),
11665 CB_NAME (pointer));
11666 return;
11667 }
11668 if (error_if_not_int_field_or_has_pic_p ("POINTER", pointer)) {
11669 return;
11670 }
11671 }
11672
11673 void
11674 cb_emit_string (cb_tree items, cb_tree into, cb_tree pointer)
11675 {
11676 cb_tree start;
11677 cb_tree l;
11678 cb_tree end;
11679 cb_tree dlm;
11680
11681 if (cb_validate_one (into)
11682 || cb_validate_one (pointer)) {
11683 return;
11684 }
11685
11686 if (pointer) {
11687 validate_pointer_clause (pointer, into);
11688 }
11689
11690 start = items;
11691 cb_emit (CB_BUILD_FUNCALL_2 ("cob_string_init", into, pointer));
11692 while (start) {
11693 /* Find next DELIMITED item */
11694 for (end = start; end; end = CB_CHAIN (end)) {
11695 if (CB_PAIR_P (CB_VALUE (end))) {
11696 break;
11697 }
11698 }
11699
11700 /* generate cob_string_delimited from delimiter */
11701 dlm = end ? CB_PAIR_X (CB_VALUE (end)) : NULL;
11702 if (dlm == cb_int0) {
11703 dlm = NULL;
11704 } else {
11705 if (cb_validate_one (dlm)) {
11706 return;
11707 }
11708 }
11709 cb_emit (CB_BUILD_FUNCALL_1 ("cob_string_delimited", dlm));
11710
11711 /* generate cob_string_append for all entries until delimiter */
11712 for (l = start; l != end; l = CB_CHAIN (l)) {
11713 if (cb_validate_one (CB_VALUE (l))) {
11714 return;
11715 }
11716 cb_emit (CB_BUILD_FUNCALL_1 ("cob_string_append",
11717 CB_VALUE (l)));
11718 }
11719
11720 start = end ? CB_CHAIN (end) : NULL;
11721 }
11722 cb_emit (CB_BUILD_FUNCALL_0 ("cob_string_finish"));
11723 }
11724
11725 /* UNLOCK statement */
11726
11727 void
11728 cb_emit_unlock (cb_tree ref)
11729 {
11730 cb_tree file;
11731
11732 file = cb_ref (ref);
11733 if (file != cb_error_node) {
11734 cb_emit (CB_BUILD_FUNCALL_2 ("cob_unlock_file",
11735 file, CB_FILE(file)->file_status));
11736 current_statement->file = file;
11737 }
11738 }
11739
11740 /* UNSTRING statement */
11741
11742 void
11743 cb_emit_unstring (cb_tree name, cb_tree delimited, cb_tree into,
11744 cb_tree pointer, cb_tree tallying)
11745 {
11746 if (cb_validate_one (name)
11747 || cb_validate_one (tallying)
11748 || cb_validate_list (delimited)
11749 || cb_validate_list (into)) {
11750 return;
11751 }
11752 if (pointer) {
11753 validate_pointer_clause (pointer, name);
11754 }
11755
11756 cb_emit (CB_BUILD_FUNCALL_3 ("cob_unstring_init", name, pointer,
11757 cb_int ((int)cb_list_length (delimited))));
11758 cb_emit_list (delimited);
11759 cb_emit_list (into);
11760 if (tallying) {
11761 cb_emit (CB_BUILD_FUNCALL_1 ("cob_unstring_tallying", tallying));
11762 }
11763 cb_emit (CB_BUILD_FUNCALL_0 ("cob_unstring_finish"));
11764 }
11765
11766 cb_tree
11767 cb_build_unstring_delimited (cb_tree all, cb_tree value)
11768 {
11769 if (cb_validate_one (value)) {
11770 return cb_error_node;
11771 }
11772 return CB_BUILD_FUNCALL_2 ("cob_unstring_delimited", value, all);
11773 }
11774
11775 cb_tree
11776 cb_build_unstring_into (cb_tree name, cb_tree delimiter, cb_tree count)
11777 {
11778 if (cb_validate_one (name)) {
11779 return cb_error_node;
11780 }
11781 if (delimiter == NULL) {
11782 delimiter = cb_int0;
11783 }
11784 if (count == NULL
11785 || error_if_not_int_field_or_has_pic_p ("COUNT", count)) {
11786 count = cb_int0;
11787 }
11788 return CB_BUILD_FUNCALL_3 ("cob_unstring_into", name, delimiter, count);
11789 }
11790
11791 /* WRITE statement */
11792
11793 void
11794 cb_emit_write (cb_tree record, cb_tree from, cb_tree opt, cb_tree lockopt)
11795 {
11796 cb_tree file;
11797 cb_tree rtree;
11798 cb_tree check_eop;
11799 struct cb_file *f;
11800
11801 if (cb_validate_one (record)
11802 || cb_validate_one (from)) {
11803 return;
11804 }
11805 rtree = cb_ref (record);
11806 if (CB_FILE_P (rtree)) {
11807 /* FILE filename: was used */
11808 if (from == NULL) {
11809 cb_error_x (CB_TREE (current_statement),
11810 _("%s FILE requires a FROM clause"), "WRITE");
11811 return;
11812 }
11813 file = rtree;
11814 f = CB_FILE (file);
11815 if (f->record->sister) {
11816 record = CB_TREE(f->record->sister);
11817 } else {
11818 record = CB_TREE(f->record);
11819 }
11820
11821 if (error_if_invalid_file_from_clause_literal (from)) {
11822 return;
11823 }
11824 } else {
11825 if (!CB_REF_OR_FIELD_P (rtree)) {
11826 cb_error_x (CB_TREE (current_statement),
11827 _("%s requires a record name as subject"), "WRITE");
11828 return;
11829 }
11830 if (CB_FIELD_PTR (record)->storage != CB_STORAGE_FILE) {
11831 cb_error_x (CB_TREE (current_statement),
11832 _("%s subject does not refer to a record name"), "WRITE");
11833 return;
11834 }
11835 file = CB_TREE (CB_FIELD (rtree)->file);
11836 if (!file || file == cb_error_node) {
11837 return;
11838 }
11839 }
11840 current_statement->file = file;
11841 f = CB_FILE (file);
11842
11843 if (cb_listing_xref) {
11844 /* add a "receiving" entry for the file */
11845 cobc_xref_link (&f->xref, current_statement->common.source_line, 1);
11846 }
11847
11848 if (f->organization == COB_ORG_SORT) {
11849 cb_error_x (CB_TREE (current_statement),
11850 _("%s not allowed on %s files"), "WRITE", "SORT");
11851 } else if (f->reports) {
11852 cb_error_x (CB_TREE (current_statement),
11853 _("%s not allowed on %s files"), "WRITE", "REPORT");
11854 return;
11855 } else if (current_statement->handler_type == INVALID_KEY_HANDLER &&
11856 (f->organization != COB_ORG_RELATIVE &&
11857 f->organization != COB_ORG_INDEXED)) {
11858 cb_error_x (CB_TREE(current_statement),
11859 _("INVALID KEY clause invalid with this file type"));
11860 } else if (lockopt) {
11861 if (f->lock_mode & COB_LOCK_AUTOMATIC) {
11862 cb_error_x (CB_TREE (current_statement),
11863 _("LOCK clause invalid with file LOCK AUTOMATIC"));
11864 } else if (opt != cb_int0) {
11865 cb_error_x (CB_TREE (current_statement),
11866 _("LOCK clause invalid here"));
11867 } else if (lockopt == cb_int1) {
11868 opt = cb_int (COB_WRITE_LOCK);
11869 }
11870 }
11871
11872 if (from && (!CB_FIELD_P(from) || (CB_FIELD_PTR (from) != CB_FIELD_PTR (record)))) {
11873 cb_emit (cb_build_move (from, record));
11874 }
11875
11876 /* Check debugging on record name */
11877 if (current_program->flag_debugging &&
11878 !current_statement->flag_in_debug &&
11879 CB_FIELD_PTR (record)->flag_field_debug) {
11880 cb_emit (cb_build_debug (cb_debug_name,
11881 CB_FIELD_PTR (record)->name, NULL));
11882 cb_emit (cb_build_move (record, cb_debug_contents));
11883 cb_emit (cb_build_debug_call (CB_FIELD_PTR (record)->debug_section));
11884 }
11885 if (f->organization == COB_ORG_LINE_SEQUENTIAL &&
11886 opt == cb_int0) {
11887 if (cb_flag_write_after || CB_FILE (file)->flag_line_adv) {
11888 opt = cb_int_hex (COB_WRITE_AFTER | COB_WRITE_LINES | 1);
11889 } else {
11890 opt = cb_int_hex (COB_WRITE_BEFORE | COB_WRITE_LINES | 1);
11891 }
11892 }
11893 if (current_statement->handler_type == EOP_HANDLER &&
11894 current_statement->ex_handler) {
11895 check_eop = cb_int1;
11896 } else {
11897 check_eop = cb_int0;
11898 }
11899 if (f->extfh) {
11900 cb_emit (CB_BUILD_FUNCALL_6 ("cob_extfh_write", f->extfh, file, record, opt,
11901 f->file_status, check_eop));
11902 } else {
11903 cb_emit (CB_BUILD_FUNCALL_5 ("cob_write", file, record, opt,
11904 f->file_status, check_eop));
11905 }
11906 }
11907
11908 cb_tree
11909 cb_build_write_advancing_lines (cb_tree pos, cb_tree lines)
11910 {
11911 cb_tree e;
11912 int opt;
11913
11914 opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
11915 opt |= COB_WRITE_LINES;
11916 if (CB_LITERAL_P (lines)) {
11917 opt |= cb_get_int (lines);
11918 return cb_int_hex (opt);
11919 }
11920 e = cb_build_binary_op (cb_int (opt), '+', lines);
11921 return cb_build_cast_int (e);
11922 }
11923
11924 cb_tree
11925 cb_build_write_advancing_mnemonic (cb_tree pos, cb_tree mnemonic)
11926 {
11927 int opt;
11928 int token;
11929 cb_tree rtree = cb_ref (mnemonic);
11930
11931 if (rtree == cb_error_node) {
11932 return cb_int0;
11933 }
11934 token = CB_SYSTEM_NAME (rtree)->token;
11935 switch (token) {
11936 case CB_FEATURE_FORMFEED: /* including S01-S05, CSP and TOP */
11937 opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
11938 return cb_int_hex (opt | COB_WRITE_PAGE);
11939 case CB_FEATURE_C01:
11940 case CB_FEATURE_C02:
11941 case CB_FEATURE_C03:
11942 case CB_FEATURE_C04:
11943 case CB_FEATURE_C05:
11944 case CB_FEATURE_C06:
11945 case CB_FEATURE_C07:
11946 case CB_FEATURE_C08:
11947 case CB_FEATURE_C09:
11948 case CB_FEATURE_C10:
11949 case CB_FEATURE_C11:
11950 case CB_FEATURE_C12:
11951 opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
11952 return cb_int_hex (opt | COB_WRITE_CHANNEL | COB_WRITE_PAGE | token);
11953 /* case CB_FEATURE_AFP_5A: what to do here? */
11954 default:
11955 cb_error_x (mnemonic, _("invalid mnemonic name"));
11956 return cb_int0;
11957 }
11958 }
11959
11960 cb_tree
11961 cb_build_write_advancing_page (cb_tree pos)
11962 {
11963 int opt = (pos == CB_BEFORE) ? COB_WRITE_BEFORE : COB_WRITE_AFTER;
11964
11965 return cb_int_hex (opt | COB_WRITE_PAGE);
11966 }
11967
11968 #ifndef HAVE_DESIGNATED_INITS
11969 void
11970 cobc_init_typeck (void)
11971 {
11972 memset(expr_prio, 0, sizeof(expr_prio));
11973 expr_prio['x' & 0xFF] = 0;
11974 expr_prio['^' & 0xFF] = 1;
11975 expr_prio['*' & 0xFF] = 2;
11976 expr_prio['/' & 0xFF] = 2;
11977 expr_prio['+' & 0xFF] = 3;
11978 expr_prio['-' & 0xFF] = 3;
11979 expr_prio['=' & 0xFF] = 4;
11980 expr_prio['~' & 0xFF] = 4;
11981 expr_prio['<' & 0xFF] = 4;
11982 expr_prio['>' & 0xFF] = 4;
11983 expr_prio['[' & 0xFF] = 4;
11984 expr_prio[']' & 0xFF] = 4;
11985 expr_prio['!' & 0xFF] = 5;
11986 expr_prio['&' & 0xFF] = 6;
11987 expr_prio['|' & 0xFF] = 7;
11988 expr_prio[')' & 0xFF] = 8;
11989 expr_prio['(' & 0xFF] = 9;
11990 expr_prio[0] = 10;
11991 }
11992 #endif
11993
11994 /*
11995 * Emit any MOVEs from non-simple field to temp field
11996 * for GENERATE to execute
11997 */
11998 static int report_in_footing = 0;
11999 static void
12000 cb_emit_report_moves (struct cb_report *r, struct cb_field *f, int forterminate)
12001 {
12002 struct cb_field *p;
12003 for (p = f; p; p = p->sister) {
12004 if(p->report_flag & (COB_REPORT_FOOTING|COB_REPORT_CONTROL_FOOTING|COB_REPORT_CONTROL_FOOTING_FINAL)) {
12005 report_in_footing = 1;
12006 }
12007 if(p->report_from) {
12008 if(forterminate
12009 && report_in_footing) {
12010 cb_emit_move (p->report_from, CB_LIST_INIT (p->report_source));
12011 } else
12012 if(!forterminate
12013 && !report_in_footing) {
12014 cb_emit_move (p->report_from, CB_LIST_INIT (p->report_source));
12015 }
12016 }
12017 if(p->report_when) {
12018 int ifwhen = 2;
12019 if(p->children)
12020 ifwhen = 3;
12021 if(forterminate
12022 && report_in_footing) {
12023 cb_emit (cb_build_if (p->report_when, NULL, (cb_tree)p, ifwhen));
12024 } else
12025 if(!forterminate
12026 && !report_in_footing) {
12027 cb_emit (cb_build_if (p->report_when, NULL, (cb_tree)p, ifwhen));
12028 }
12029 }
12030 if(p->children) {
12031 cb_emit_report_moves(r, p->children, forterminate);
12032 if(p->report_flag & (COB_REPORT_FOOTING|COB_REPORT_CONTROL_FOOTING|COB_REPORT_CONTROL_FOOTING_FINAL)) {
12033 report_in_footing = 0;
12034 }
12035 }
12036 }
12037 }
12038
12039 static void
12040 cb_emit_report_move_id (cb_tree rep)
12041 {
12042 struct cb_report *r = CB_REPORT_PTR (rep);
12043 if (r
12044 && r->id == 0) {
12045 r->id = report_id++;
12046 cb_emit (CB_BUILD_FUNCALL_1 ("$M", rep));
12047 cb_emit_report_moves(r, r->records, 0);
12048 cb_emit (CB_BUILD_FUNCALL_1 ("$t", rep));
12049 cb_emit_report_moves(r, r->records, 1);
12050 cb_emit (CB_BUILD_FUNCALL_1 ("$m", rep));
12051 }
12052 }
12053
12054 /* INITIATE statement */
12055
12056 void
12057 cb_emit_initiate (cb_tree rep)
12058 {
12059 if (rep == cb_error_node) {
12060 return;
12061 }
12062 cb_emit_report_move_id (rep);
12063 cb_emit (CB_BUILD_FUNCALL_1 ("$I", rep));
12064
12065 }
12066
12067 /* TERMINATE statement */
12068
12069 void
12070 cb_emit_terminate (cb_tree rep)
12071 {
12072 if (rep == cb_error_node) {
12073 return;
12074 }
12075 cb_emit_report_move_id (rep);
12076 cb_emit (CB_BUILD_FUNCALL_1 ("$T", rep));
12077
12078 }
12079
12080 /* GENERATE statement */
12081
12082 void
12083 cb_emit_generate (cb_tree x)
12084 {
12085 struct cb_field *f;
12086 struct cb_report *r;
12087 cb_tree y;
12088 cb_tree z;
12089 if (x == cb_error_node) {
12090 return;
12091 }
12092 if (CB_REFERENCE_P (x)) {
12093 y = cb_ref (x);
12094 if (y == cb_error_node) {
12095 return;
12096 }
12097 } else {
12098 y = x;
12099 }
12100 if(CB_REPORT_P (y)) {
12101 r = CB_REPORT (y);
12102 z = cb_build_reference (r->name);
12103 CB_REFERENCE (z)->value = CB_TREE (y);
12104 cb_emit_report_move_id(z);
12105 cb_emit (CB_BUILD_FUNCALL_2 ("$R", z, NULL));
12106 return;
12107 }
12108 f = CB_FIELD (y);
12109 if(f == NULL
12110 || f->report == NULL) {
12111 cb_error_x (x, _("data item is not part of a report"));
12112 } else {
12113 z = cb_build_reference (f->name);
12114 CB_REFERENCE (z)->value = CB_TREE (f->report);
12115 x->tag = CB_TAG_REPORT_LINE;
12116 cb_emit_report_move_id(z);
12117 cb_emit (CB_BUILD_FUNCALL_2 ("$R", z, x));
12118 }
12119 }
12120
12121 /* SUPPRESS statement */
12122
12123 void
12124 cb_emit_suppress (struct cb_field *f)
12125 {
12126 cb_tree z;
12127 /* MORE TO DO HERE */
12128 /* Find cob_report_control and set on suppress flag */
12129 if(f == NULL
12130 || f->report == NULL) {
12131 cb_error (_("improper use of SUPPRESS PRINTING"));
12132 return;
12133 }
12134 z = cb_build_reference (f->name);
12135 CB_REFERENCE (z)->value = CB_TREE (f->report);
12136 cb_emit (CB_BUILD_FUNCALL_2 ("$S", z, cb_int (f->id)));
12137 }
12138
12139 /* JSON/XML GENERATE statement */
12140
12141 static int
12142 error_if_not_alnum_or_national (cb_tree ref, const char *name)
12143 {
12144 if (!(CB_TREE_CATEGORY (ref) == CB_CATEGORY_ALPHANUMERIC
12145 || CB_TREE_CATEGORY (ref) == CB_CATEGORY_NATIONAL)) {
12146 cb_error_x (ref, _("%s must be alphanumeric or national"), name);
12147 return 1;
12148 } else {
12149 return 0;
12150 }
12151 }
12152
12153 static int
12154 error_if_figurative_constant (cb_tree ref, const char *name)
12155 {
12156 if (cb_is_figurative_constant (ref)) {
12157 cb_error_x (ref, _("%s may not be a figurative constant"), name);
12158 return 1;
12159 } else {
12160 return 0;
12161 }
12162 }
12163
12164 static int
12165 is_subordinate_to (cb_tree ref, cb_tree parent_ref)
12166 {
12167 struct cb_field *f = CB_FIELD (cb_ref (ref))->parent;
12168 struct cb_field *parent = CB_FIELD (cb_ref (parent_ref));
12169
12170 for (; f; f = f->parent) {
12171 if (f == parent) {
12172 return 1;
12173 }
12174 }
12175
12176 return 0;
12177 }
12178
12179 static int
12180 is_subordinate_to_fields (struct cb_field* f, struct cb_field* parent)
12181 {
12182 for (f = f->parent; f; f = f->parent) {
12183 if (f == parent) {
12184 return 1;
12185 }
12186 }
12187
12188 return 0;
12189 }
12190
12191 static int
12192 error_if_not_child_of_input_record (cb_tree ref, cb_tree input_record,
12193 const char *name)
12194 {
12195 if (!is_subordinate_to (ref, input_record)) {
12196 cb_error_x (ref, _("%s must be a child of the input record"), name);
12197 return 1;
12198 } else {
12199 return 0;
12200 }
12201 }
12202
12203 static int
12204 is_ignored_child_in_ml_gen (cb_tree ref, cb_tree parent_ref)
12205 {
12206 struct cb_field *f = CB_FIELD (cb_ref (ref));
12207 struct cb_field *parent = CB_FIELD (cb_ref (parent_ref));
12208
12209 for (; f && f != parent; f = f->parent) {
12210 if (cb_field_is_ignored_in_ml_gen (f)) {
12211 return 1;
12212 }
12213 }
12214
12215 return 0;
12216 }
12217
12218 static int
12219 error_if_ignored_in_ml_gen (cb_tree ref, cb_tree input_record, const char *name)
12220 {
12221 if (is_ignored_child_in_ml_gen (ref, input_record)) {
12222 cb_error_x (ref, _("%s may not be an ignored item in JSON/XML GENERATE"), name);
12223 return 1;
12224 } else {
12225 return 0;
12226 }
12227 }
12228
12229 static int
12230 error_if_not_elementary (cb_tree ref, const char *name)
12231 {
12232 if (CB_FIELD (cb_ref (ref))->children) {
12233 cb_error_x (ref, _("%s must be elementary"), name);
12234 return 1;
12235 } else {
12236 return 0;
12237 }
12238 }
12239
12240 static int
12241 error_if_not_usage_display_or_national (cb_tree ref, const char *name)
12242 {
12243 if (!(CB_FIELD (cb_ref (ref))->usage == CB_USAGE_DISPLAY
12244 || CB_FIELD (cb_ref (ref))->usage == CB_USAGE_NATIONAL)) {
12245 cb_error_x (ref, _("%s must be USAGE DISPLAY or NATIONAL"), name);
12246 return 1;
12247 } else {
12248 return 0;
12249 }
12250 }
12251
12252 static int
12253 error_if_not_integer_ref (cb_tree ref, const char *name)
12254 {
12255 struct cb_field *field = CB_FIELD (cb_ref (ref));
12256
12257 if (CB_TREE_CATEGORY (field) == CB_CATEGORY_NUMERIC
12258 && field->pic && field->pic->scale > 0) {
12259 cb_error_x (ref, _("%s must be an integer"), name);
12260 return 1;
12261 } else {
12262 return 0;
12263 }
12264 }
12265
12266 static int
12267 syntax_check_ml_gen_receiving_item (cb_tree out)
12268 {
12269 int error = 0;
12270
12271 if (cb_validate_one (out)) {
12272 return 1;
12273 }
12274
12275 error |= error_if_not_alnum_or_national (out, _("JSON/XML GENERATE receiving item"));
12276
12277 if (CB_FIELD (cb_ref (out))->flag_justified) {
12278 cb_error_x (out, _("JSON/XML GENERATE receiving item may not have JUSTIFIED clause"));
12279 error = 1;
12280 }
12281 error |= error_if_subscript_or_refmod (out, _("JSON/XML GENERATE receiving item"));
12282
12283 return error;
12284 }
12285
12286 static int
12287 all_children_are_ignored (struct cb_field * const f)
12288 {
12289 struct cb_field *child;
12290
12291 for (child = f->children; child; child = child->sister) {
12292 if (!cb_field_is_ignored_in_ml_gen (child)
12293 && !(child->children
12294 && all_children_are_ignored (child))) {
12295 return 0;
12296 }
12297 }
12298
12299 return 1;
12300 }
12301
12302 static int
12303 name_is_unique_when_qualified_by (struct cb_field * const f,
12304 struct cb_field * const qualifier)
12305 {
12306 cb_tree qual_ref = cb_build_field_reference (qualifier, NULL);
12307 cb_tree f_ref = cb_build_reference (f->name);
12308 CB_REFERENCE (f_ref)->chain = qual_ref;
12309
12310 return cb_try_ref (f_ref) != cb_error_node;
12311 }
12312
12313 static int
12314 all_children_ok_qualified_by_only (struct cb_field * const f,
12315 struct cb_field * const qualifier)
12316 {
12317 struct cb_field *child;
12318
12319 for (child = f->children; child; child = child->sister) {
12320 if (child->flag_filler) {
12321 continue;
12322 }
12323
12324 if (!name_is_unique_when_qualified_by (child, qualifier)) {
12325 return 0;
12326 }
12327 if (child->children
12328 && !all_children_ok_qualified_by_only (child, qualifier)) {
12329 return 0;
12330 }
12331 }
12332
12333 return 1;
12334 }
12335
12336
12337 static int
12338 contains_floating_point_item (const struct cb_field * const f, const int check_siblings)
12339 {
12340 return is_floating_point_usage (f->usage)
12341 || (f->children && contains_floating_point_item (f->children, 1))
12342 || (check_siblings && f->sister
12343 && contains_floating_point_item (f->sister, 1));
12344 }
12345
12346 static int
12347 contains_occurs_item (const struct cb_field * const f, const int check_siblings)
12348 {
12349 return f->flag_occurs
12350 || (f->children && contains_occurs_item (f->children, 1))
12351 || (check_siblings && f->sister
12352 && contains_occurs_item (f->sister, 1));
12353 }
12354
12355 static int
12356 syntax_check_ml_gen_input_rec (cb_tree from)
12357 {
12358 int error = 0;
12359 struct cb_field *from_field;
12360
12361 if (cb_validate_one (from)) {
12362 return 1;
12363 }
12364
12365 if (CB_REFERENCE (from)->offset) {
12366 cb_error_x (from, _("JSON/XML GENERATE input record may not be reference modified"));
12367 error = 1;
12368 }
12369
12370 from_field = CB_FIELD (cb_ref (from));
12371 if (from_field->rename_thru) {
12372 cb_error_x (from, _("JSON/XML GENERATE input record may not have RENAMES clause"));
12373 error = 1;
12374 }
12375
12376 if (from_field->children && all_children_are_ignored (from_field)) {
12377 cb_error_x (from, _("all the children of '%s' are ignored in JSON/XML GENERATE"),
12378 cb_name (from));
12379 error = 1;
12380 }
12381
12382 if (!all_children_ok_qualified_by_only (from_field, from_field)) {
12383 /* TO-DO: Output the name of the child with the nonunique name */
12384 cb_error_x (from, _("JSON/XML GENERATE input record has subrecords with non-unique names"));
12385 error = 1;
12386 }
12387
12388 if (contains_floating_point_item (from_field, 0)) {
12389 CB_PENDING (_("floating-point items in JSON/XML GENERATE"));
12390 }
12391
12392 if (contains_occurs_item (from_field, 0)) {
12393 CB_PENDING (_("OCCURS items in JSON/XML GENERATE"));
12394 }
12395
12396 return error;
12397 }
12398
12399 static int
12400 syntax_check_ml_gen_count_in (cb_tree count)
12401 {
12402 return error_if_not_int_field_or_has_pic_p ("COUNT IN", count);
12403 }
12404
12405 static int
12406 is_valid_uri (const struct cb_literal * const namespace)
12407 {
12408 size_t size = (size_t)namespace->size;
12409 char *copy = cob_malloc (size + 1);
12410 int is_valid;
12411
12412 memcpy (copy, namespace->data, size);
12413 copy[size] = '\0';
12414 is_valid = cob_is_valid_uri (copy);
12415 cob_free (copy);
12416
12417 return is_valid;
12418 }
12419
12420
12421 static int
12422 syntax_check_xml_gen_namespace (cb_tree namespace)
12423 {
12424 int error = 0;
12425
12426 if (!namespace) {
12427 return 0;
12428 }
12429
12430 if (cb_validate_one (namespace)) {
12431 return 1;
12432 }
12433
12434 error |= error_if_not_alnum_or_national (namespace, "NAMESPACE");
12435
12436 if (error_if_figurative_constant (namespace, "NAMESPACE")) {
12437 error = 1;
12438 } else {
12439 if (CB_LITERAL_P (namespace) && !is_valid_uri (CB_LITERAL (namespace))) {
12440 cb_error_x (namespace, _("NAMESPACE must be a valid URI"));
12441 error = 1;
12442 }
12443 }
12444
12445 return error;
12446 }
12447
12448 static int
12449 is_valid_xml_name (const struct cb_literal * const name)
12450 {
12451 unsigned int i;
12452
12453 if (!cob_is_xml_namestartchar (name->data[0])) {
12454 return 0;
12455 }
12456
12457 for (i = 1; i < name->size; ++i) {
12458 if (!cob_is_xml_namechar (name->data[i])) {
12459 return 0;
12460 }
12461 }
12462
12463 return 1;
12464 }
12465
12466 static int
12467 syntax_check_xml_gen_prefix (cb_tree prefix)
12468 {
12469 int error = 0;
12470
12471 if (prefix == cb_null) {
12472 return 0;
12473 }
12474
12475 if (cb_validate_one (prefix)) {
12476 return 1;
12477 }
12478
12479 error |= error_if_not_alnum_or_national (prefix, "NAMESPACE-PREFIX");
12480
12481 if (error_if_figurative_constant (prefix, "NAMESPACE-PREFIX")) {
12482 error = 1;
12483 } else if (CB_LITERAL_P (prefix) && !is_valid_xml_name (CB_LITERAL (prefix))) {
12484 cb_error_x (prefix, _("NAMESPACE-PREFIX must be a valid XML name"));
12485 error = 1;
12486 }
12487
12488 return error;
12489 }
12490
12491 static int
12492 syntax_check_ml_gen_name_list (cb_tree name_list, cb_tree input, const int is_xml)
12493 {
12494 cb_tree name_pair;
12495 cb_tree ref;
12496 cb_tree name;
12497 cb_tree l;
12498 struct cb_field *reference_field;
12499 struct cb_field *input_field = CB_FIELD (cb_ref (input));
12500 int error = 0;
12501
12502 for (l = name_list; l; l = CB_CHAIN (l)) {
12503 name_pair = CB_VALUE (l);
12504 ref = CB_PAIR_X (name_pair);
12505 name = CB_PAIR_Y (name_pair);
12506 if (cb_validate_one (ref)
12507 || cb_validate_one (name)) {
12508 error = 1;
12509 continue;
12510 }
12511 reference_field = CB_FIELD (cb_ref (ref));
12512
12513 error |= error_if_subscript_or_refmod (ref, _("NAME OF item"));
12514
12515 if (reference_field != input_field
12516 && !is_subordinate_to_fields (reference_field, input_field)) {
12517 cb_error_x (ref,
12518 _("NAME OF item must be the input record or a child of it"));
12519 error = 1;
12520 } else {
12521 error |= error_if_ignored_in_ml_gen (ref, input, _("NAME OF item"));
12522 }
12523
12524 if (name == cb_null) {
12525 /* note: only allowed for JSON in the parser */
12526 if (reference_field != input_field) {
12527 cb_error_x (ref,
12528 _("NAME OF ... OMITTED only valid for source identifier"));
12529 error = 1;
12530 }
12531 continue;
12532 }
12533
12534 if (!is_valid_xml_name (CB_LITERAL (name))) {
12535 cb_error_x (ref,
12536 _("NAME OF literal must be a valid %s identifier"),
12537 is_xml ? "XML" : "JSON");
12538 error = 1;
12539 }
12540 }
12541
12542 return error;
12543 }
12544
12545 static int
12546 syntax_check_ml_gen_type_list (cb_tree type_list, cb_tree input)
12547 {
12548 cb_tree l;
12549 cb_tree type_pair;
12550 cb_tree ref;
12551 cb_tree type;
12552 int error = 0;
12553
12554 for (l = type_list; l; l = CB_CHAIN (l)) {
12555 type_pair = CB_VALUE (l);
12556 ref = CB_PAIR_X (type_pair);
12557 type = CB_PAIR_Y (type_pair);
12558 if (cb_validate_one (ref)
12559 || cb_validate_one (type)) {
12560 return 1;
12561 }
12562
12563 error |= error_if_subscript_or_refmod (ref, _("TYPE OF item"));
12564 error |= error_if_not_elementary (ref, _("TYPE OF item"));
12565
12566 if (error_if_not_child_of_input_record (ref, input,
12567 _("TYPE OF item"))) {
12568 error = 1;
12569 } else {
12570 error |= error_if_ignored_in_ml_gen (ref, input,
12571 _("TYPE OF item"));
12572 }
12573 }
12574
12575 return error;
12576 }
12577
12578 static int
12579 syntax_check_when_list (struct cb_ml_suppress_clause *suppress)
12580 {
12581 cb_tree l;
12582 int error = 0;
12583 const char *name;
12584
12585 for (l = suppress->when_list; l; l = CB_CHAIN (l)) {
12586 /* TO-DO: Handle DISPLAY-1 if/when it is supported. */
12587 if (CB_VALUE (l) == cb_space) {
12588 error |= error_if_not_usage_display_or_national (suppress->identifier,
12589 _("SUPPRESS WHEN SPACE item"));
12590 } else if (CB_VALUE (l) == cb_low || CB_VALUE (l) == cb_high) {
12591 if (CB_VALUE (l) == cb_low) {
12592 name = _("SUPPRESS WHEN LOW-VALUE item");
12593 } else {
12594 name = _("SUPPRESS WHEN HIGH-VALUE item");
12595 }
12596 error |= error_if_not_usage_display_or_national (suppress->identifier,
12597 name);
12598 error |= error_if_not_integer_ref (suppress->identifier, name);
12599 }
12600 }
12601
12602 return error;
12603 }
12604
12605 static int
12606 syntax_check_ml_gen_suppress_list (cb_tree suppress_list, cb_tree input)
12607 {
12608 int error = 0;
12609 cb_tree l;
12610 struct cb_ml_suppress_clause *suppress;
12611
12612 for (l = suppress_list; l; l = CB_CHAIN (l)) {
12613 suppress = CB_ML_SUPPRESS (CB_VALUE (l));
12614 if (!suppress->identifier) {
12615 continue;
12616 }
12617
12618 if (cb_validate_one (suppress->identifier)) {
12619 return 1;
12620 }
12621
12622 error |= error_if_subscript_or_refmod (suppress->identifier,
12623 _("SUPPRESS item"));
12624
12625 if (suppress->when_list) {
12626 error |= error_if_not_elementary (suppress->identifier,
12627 _("SUPPRESS item with WHEN clause"));
12628 }
12629
12630 if (error_if_not_child_of_input_record (suppress->identifier, input,
12631 _("SUPPRESS item"))) {
12632 error = 1;
12633 } else {
12634 error |= error_if_ignored_in_ml_gen (suppress->identifier,
12635 input, _("SUPPRESS item"));
12636 }
12637
12638 error |= syntax_check_when_list (suppress);
12639 }
12640
12641 return error;
12642 }
12643
12644 static int
12645 syntax_check_ml_generate (cb_tree out, cb_tree from, cb_tree count,
12646 cb_tree encoding,
12647 cb_tree namespace_and_prefix,
12648 cb_tree name_list, cb_tree type_list,
12649 cb_tree suppress_list, const int is_xml)
12650 {
12651 int error = 0;
12652
12653 error |= syntax_check_ml_gen_receiving_item (out);
12654 error |= syntax_check_ml_gen_input_rec (from);
12655 error |= syntax_check_ml_gen_count_in (count);
12656 COB_UNUSED (encoding); /* TODO: check encoding */
12657 if (namespace_and_prefix) {
12658 error |= syntax_check_xml_gen_namespace (CB_PAIR_X (namespace_and_prefix));
12659 error |= syntax_check_xml_gen_prefix (CB_PAIR_Y (namespace_and_prefix));
12660 }
12661 error |= syntax_check_ml_gen_name_list (name_list, from, is_xml);
12662 error |= syntax_check_ml_gen_type_list (type_list, from);
12663 error |= syntax_check_ml_gen_suppress_list (suppress_list, from);
12664
12665 /* TO-DO: Warn if out is probably too short */
12666 /* TO-DO: Warn if count_in may overflow */
12667
12668 return error;
12669 }
12670
12671 void
12672 cb_emit_xml_generate (cb_tree out, cb_tree from, cb_tree count,
12673 cb_tree encoding,
12674 const int with_xml_dec,
12675 const int with_attrs,
12676 cb_tree namespace_and_prefix,
12677 cb_tree name_list, cb_tree type_list,
12678 cb_tree suppress_list)
12679 {
12680 struct cb_ml_generate_tree *tree;
12681 unsigned char decimal_point;
12682
12683 if (syntax_check_ml_generate (out, from, count, encoding,
12684 namespace_and_prefix, name_list,
12685 type_list, suppress_list, 1)) {
12686 return;
12687 }
12688
12689 tree = CB_ML_TREE (cb_build_ml_tree (CB_FIELD (cb_ref (from)),
12690 with_attrs, 0, name_list,
12691 type_list, suppress_list));
12692
12693 tree->sibling = current_program->ml_trees;
12694 current_program->ml_trees = tree;
12695
12696 if (with_attrs && !tree->attrs) {
12697 cb_warning (cb_warn_additional,
12698 _("WITH ATTRIBUTES specified, but no attributes can be generated"));
12699 }
12700
12701 cb_emit (cb_build_ml_suppress_checks (tree));
12702 if (cb_dpc_in_data == CB_DPC_IN_XML
12703 || cb_dpc_in_data == CB_DPC_IN_ALL) {
12704 decimal_point = current_program->decimal_point;
12705 } else {
12706 decimal_point = '.';
12707 }
12708 if (namespace_and_prefix) {
12709 cb_emit (CB_BUILD_FUNCALL_7 ("cob_xml_generate_new", out, CB_TREE (tree),
12710 count, cb_int (with_xml_dec),
12711 CB_PAIR_X (namespace_and_prefix),
12712 CB_PAIR_Y (namespace_and_prefix),
12713 cb_int (decimal_point)));
12714 } else {
12715 cb_emit (CB_BUILD_FUNCALL_7 ("cob_xml_generate_new", out, CB_TREE (tree),
12716 count, cb_int (with_xml_dec),
12717 NULL, NULL, cb_int (decimal_point)));
12718 }
12719 }
12720
12721 void
12722 cb_emit_json_generate (cb_tree out, cb_tree from, cb_tree count,
12723 cb_tree name_list, cb_tree suppress_list)
12724 {
12725 struct cb_ml_generate_tree *tree;
12726 unsigned char decimal_point;
12727
12728 #if 0 /* pending merge of cb_warn_unsupported */
12729 if (current_statement->ex_handler == NULL
12730 && current_statement->not_ex_handler == NULL)
12731 current_statement->handler_type = NO_HANDLER;
12732 #if !defined (WITH_CJSON) && !defined (WITH_JSON_C)
12733 if (!warn_json_done) {
12734 warn_json_done = 1;
12735 cb_warning (cb_warn_unsupported,
12736 _("compiler is not configured to support %s"), "JSON");
12737 }
12738 #endif
12739 #endif
12740 if (syntax_check_ml_generate (out, from, count, NULL,
12741 NULL, name_list,
12742 NULL, suppress_list, 0)) {
12743 return;
12744 }
12745
12746 tree = CB_ML_TREE (cb_build_ml_tree (CB_FIELD (cb_ref (from)),
12747 0, 0, name_list,
12748 NULL, suppress_list));
12749
12750 tree->sibling = current_program->ml_trees;
12751 current_program->ml_trees = tree;
12752
12753 cb_emit (cb_build_ml_suppress_checks (tree));
12754
12755 if (cb_dpc_in_data == CB_DPC_IN_JSON
12756 || cb_dpc_in_data == CB_DPC_IN_ALL) {
12757 decimal_point = current_program->decimal_point;
12758 } else {
12759 decimal_point = '.';
12760 }
12761 cb_emit (CB_BUILD_FUNCALL_4 ("cob_json_generate_new", out, CB_TREE (tree),
12762 count, cb_int (decimal_point)));
12763 }
12764